#!/usr/bin/perl

# fcscs - fast curses screen content select

# Copyright (C) 2013-2016  Simon Ruderich
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.


use strict;
use warnings;

use v5.10; # say, state

use Encode ();
use Fcntl ();
use I18N::Langinfo ();

use Curses ();

our $VERSION = '0.01';


=head1 NAME

fcscs - fast curses screen content select

=head1 SYNOPSIS

B<fcscs> [I<options>] I<path/to/screen/capture/file>

=head1 DESCRIPTION

B<fcscs> is a small tool which allows quick selection of terminal screen
contents (like URLs, paths, regex matches, etc.) and passes the selection to
GNU Screen's or Tmux's buffer or any other program. The selection can then
quickly be pasted, e.g. in the shell. Requires GNU Screen or Tmux. It's
licensed under the GPL 3 or later.

=head1 OPTIONS

None so far.

=head1 USAGE

Short overview of the general usage, details below:

    - start fcscs
    - configure actions (optional)
        - enable pasting
        - ...
    - select mode (optional, URL mode is used on startup):
        - f: file paths
        - u: URLs
        - ...
        - /: search mode
    - for `normal' modes:
        - select match by displayed number or <return> for lowest numbered
          match
        - configured action is run, e.g. URL is opened with browser
    - for `search' mode:
        - perform incremental search
        - on <return> go to `normal' mode to select a match
        - after the match is selected wait for confirmation or extension
        - confirmation: <return> run previously selected action
        - extension: change match, e.g. select complete word or line

GNU Screen setup (add to F<~/.screenrc>):

    bind ^B eval "hardcopy $HOME/.tmp/screen-fcscs" "screen fcscs $HOME/.tmp/screen-fcscs"

Tmux setup (add to F<~/.tmux.conf>):

    bind-key C-b capture-pane \; save-buffer ~/.tmp/tmux-fcscs \; delete-buffer \; new-window "fcscs ~/.tmp/tmux-fcscs"

This requires a writable ~/.tmp directory. Adapt the mapping according to your
preferences. Ensure these files are not readable by others as they can contain
private data (umask or protected directory). B<fcscs> must be in your C<$PATH>
for the above mappings to work.

Pressing the configured mapping (Prefix Ctrl-B in this example) opens B<fcscs>
in a new GNU screen/Tmux window. After selection, the content is either passed
to external programs (e.g. for URLs) or copied to the paste buffer or directly
pasted in your previous window and the new window is closed.

To select a match just type its number. If the match is unique, the entry is
automatically selected (e.g. you press 2 and there are only 19 matches). If
there are multiple matches left (e.g. you press 1 and there are more than ten
matches available), press return to select the current match (1 in this case)
or another number to select the longer match. Use backspace to remove the last
entered number.

Press return before entering a number to select the last (lowest numbered)
match (underlined by default). To abort without selecting any match either use
"q".

To change the selection mode (e.g. paths, files, etc.) use one of the mappings
explained below. Per default URLs are selected, see options for a way to
change this.

I<NOTE>: Opening URLs in the browser passes the URL via the command line which
leaks URLs to other users on the current system via C<ps aux> or C<top>.

I<NOTE>: When yanking (copying) a temporary file is used to pass the data to
GNU screen/Tmux without exposing it to C<ps aux> or C<top>. However this may
leak data if those temporary files are written to disk. To prevent this change
your C<$TMP> to point to a memory-only location or encrypted storage.

If no window appears, try running B<fcscs> manually to catch the error message
and please report the bug:

    fcscs /path/to/screen-or-tmux-fcscs-file


=head1 MODES

=cut


# CLASSES

# Helper class for drawing on the screen using Curses.
package Screen {
    sub init {
        my ($class, $encoding) = @_;

        # Prefer strict UTF-8 handling (see perldoc Encode); just in case.
        if (lc $encoding eq 'utf8') {
            $encoding = 'UTF-8';
        }
        # Get Encode object to speed up decode()/encode().
        my $encoding_object = Encode::find_encoding($encoding);
        die "unsupported encoding '$encoding'" unless ref $encoding_object;

        my $curses = Curses->new or die $!;

        my $self = {
            encoding        => $encoding,
            encoding_object => $encoding_object,
            curses          => $curses,
            debug           => 0,
            prompt          => {
                flags => undef,
                name  => undef,
                value => undef,
            },
        };
        bless $self, $class;

        Curses::start_color;
        # Allow default colors by passing -1 to init_pair. A default color is
        # not drawn on screen thus allowing terminals with pseudo-transparency
        # to use the transparent background in place of the default color.
        Curses::use_default_colors;

        Curses::cbreak;
        Curses::noecho;
        $self->cursor(0);

        return $self;
    }
    sub deinit {
        my ($self) = @_;

        Curses::nocbreak;
        Curses::echo;
        $self->cursor(1);

        Curses::endwin;
        return;
    }

    # Convert between Perl's internal encoding and the terminal's encoding.
    sub encode {
        my ($self, $string) = @_;
        return $self->{encoding_object}->encode($string);
    }
    sub decode {
        my ($self, $string) = @_;
        return eval { # returns undef on decode failure
            $self->{encoding_object}->decode($string, Encode::FB_CROAK);
        };
    }

    # Create attribute for the given fore-/background colors.
    sub color_pair {
        my ($self, $fg, $bg) = @_;

        state $next_color_pair = 1; # must start at 1 for init_pair()

        Curses::init_pair($next_color_pair, $fg, $bg);
        return Curses::COLOR_PAIR($next_color_pair++);
    }

    # Draw a string which must fit in the current line. Wrapping/clipping is
    # not supported and must be handled by the caller.
    sub draw_simple {
        my ($self, $y, $x, $attributes, $string) = @_;

        die if $string =~ /\n/;
        # FIXME: wide characters
        die if $x + length $string > $self->width;

        $self->{curses}->attron($attributes) if defined $attributes;
        $self->{curses}->addstr($y, $x, $self->encode($string));
        $self->{curses}->attroff($attributes) if defined $attributes;
        return;
    }
    # Like draw_simple(), but the string is automatically clipped.
    sub draw_clipped {
        my ($self, $y, $x, $attributes, $string) = @_;

        # FIXME: wide characters
        $string = substr $string, 0, $self->width - $x;
        $self->draw_simple($y, $x, $attributes, $string);
        return;
    }
    sub draw {
        my ($self, $y, $x, $attributes, $string) = @_;

        die unless defined $string;

        while (1) {
            my $offset;
            # We must print each line separately. Search for next newline or
            # line end, whichever is closer.
            if ($string =~ /\n/) {
                $offset = $-[0];
            }
            # FIXME: wide characters
            if ($x + length $string > $self->width) {
                my $new_offset = $self->width - $x;
                if (not defined $offset or $offset > $new_offset) {
                    $offset = $new_offset;
                }
            }
            last unless defined $offset;

            # FIXME: wide characters
            $self->draw_simple($y, $x, $attributes, substr $string, 0, $offset);

            # Don't draw "\n" itself.
            if ("\n" eq substr $string, $offset, 1) {
                $offset++;
            }

            $string = substr $string, $offset;

            $y++;
            $x = 0;
        }

        $self->draw_simple($y, $x, $attributes, $string);
        return $y;
    }

    sub draw_prompt {
        my ($self, $config) = @_;

        $self->debug('draw_prompt', 'started');

        my $x = 0;
        my $y = $self->height - 1;

        # Clear line for better visibility.
        $self->draw_simple($y, $x, undef, ' ' x $self->width);

        # Draw prompt flags.
        if (defined (my $s = $self->{prompt}{flags})) {
            $s = "[$s]";
            $self->debug('draw_prompt', $s);
            $self->draw_clipped($y, $x, $config->{attribute}{prompt_flags}, $s);
            $x += length($s) + 1; # space between next element
        }
        # Draw prompt name.
        if (defined (my $s = $self->{prompt}{name})) {
            $s = "[$s]";
            $self->debug('draw_prompt', $s);
            $self->draw_clipped($y, $x, $config->{attribute}{prompt_name}, $s);
            $x += length($s) + 1;
        }
        # Draw prompt value, e.g. a search field.
        if (defined (my $s = $self->{prompt}{value})) {
            $self->debug('draw_prompt', $s);
            $self->draw_clipped($y, $x, undef, $s);
            $x += length($s) + 1;
        }
        return;
    }

    sub draw_matches {
        my ($self, $config, $matches_remove, $matches_add) = @_;

        foreach (@{$matches_remove}) {
            $self->draw($_->{y}, $_->{x}, Curses::A_NORMAL, $_->{string});
        }

        my $attr_id     = $config->{attribute}{match_id};
        my $attr_string = $config->{attribute}{match_string};
        my $attr_last   = $config->{attribute}{match_last};

        foreach (@{$matches_add}) {
            my $attr = (defined $_->{id} and $_->{id} == 1)
                     ? $attr_last
                     : $attr_string;
            $self->draw($_->{y}, $_->{x}, $attr, $_->{string});
            if (defined $_->{id}) {
                $self->draw($_->{y}, $_->{x}, $attr_id, $_->{id});
            }
        }
        return;
    }

    sub die {
        my ($self, @args) = @_;

        my $attr = $self->color_pair(Curses::COLOR_RED, -1) | Curses::A_BOLD;

        # Clear the screen to improve visibility of the error message.
        $self->{curses}->clear;

        my $y = $self->draw(0, 0, $attr, "@args");

        if ($self->{debug}) {
            my $msg;
            eval {
                require Devel::StackTrace;
            };
            if ($@) {
                $msg = "Devel::StackTrace missing, no stack trace.\n";
            } else {
                my $trace = Devel::StackTrace->new;
                $msg = "Stack trace:\n" . $trace->as_string;
            }
            $y = $self->draw($y + 1, 0, Curses::A_NORMAL, $msg);
        }

        $self->draw($y + 1, 0, Curses::A_NORMAL,
                    'Press any key to terminate fcscs.');
        $self->refresh;

        $self->getch;
        $self->deinit;
        exit 1;
    }
    sub debug {
        my ($self, $module, @args) = @_;

        return if not $self->{debug};

        state $fh; # only open the file once per run
        if (not defined $fh) {
            # Ignore errors if the directory doesn't exist.
            if (not open $fh, '>', "$ENV{HOME}/.config/fcscs/log") {
                $fh = undef; # a failed open still writes a value to $fh
                return;
            }
        }

        foreach (@args) {
            $_ = $self->encode($_);
        }
        say $fh "$module: @args";
        return;
    }


    sub prompt {
        my ($self, %settings) = @_;

        foreach (keys %settings) {
            CORE::die if not exists $self->{prompt}{$_};
            $self->{prompt}{$_} = $settings{$_};
        }
        return;
    }

    # Wrapper for Curses.
    sub width   { return $Curses::COLS; }
    sub height  { return $Curses::LINES; }
    sub refresh { return $_[0]->{curses}->refresh; }
    sub getch   { return $_[0]->{curses}->getch; }
    sub cursor  { Curses::curs_set($_[1]); return; }
}



# FUNCTIONS

sub prepare_input {
    my ($screen, $input_ref) = @_;

    # Make sure the input fits on the screen by removing the top lines if
    # necessary.
    splice @{$input_ref}, 0, -$screen->height;

    # Pad each line with spaces to the screen width to correctly handle
    # multi-line regexes.
    # FIXME: wide characters
    my @padded = map { sprintf '%-*s', $screen->width, $_ } @{$input_ref};

    my $string = join "\n", @padded;
    return {
        string => $string,
        lines  => $input_ref,
        width  => $screen->width + 1,
                  # + 1 = "\n", used in input_match_offset_to_coordinates
    };
}

sub input_match_offset_to_coordinates {
    my ($width, $offset) = @_;

    die unless defined $offset;

    my $y = int($offset / $width);
    my $x = $offset - $y * $width;
    return ($x, $y);
}

sub get_regex_matches {
    my ($input, $regex) = @_;

    my @matches;
    while ($input->{string} =~ /$regex/g) {
        my $offset = $-[1];
        die "Match group required in regex '$regex'" if not defined $offset;

        my ($x, $y) = input_match_offset_to_coordinates($input->{width},
                                                        $offset);
        push @matches, { x => $x, y => $y, offset => $offset, string => $1 };
    }
    return @matches;
}


sub run_command {
    my ($screen, $config, $cmd) = @_;

    $screen->debug('run_command', "running @{$cmd}");

    my $exit = do {
        # Perl's system() combined with a $SIG{__WARN__} which die()s has
        # issues due to the fork. The die() in the __WARN__ handler doesn't
        # die but the program continues after the system().
        #
        # If the forked process fails to exec (e.g. program not found) then
        # the __WARN__ handler is called (because a warning is about to be
        # displayed) and the die() should display a message and terminate the
        # process. But due to the fork it doesn't terminate the parent process
        # and instead changes the return value of system(); it's no longer -1
        # which makes it impossible to detect that case.
        #
        # Perl < 5.18 (found in 5.14) doesn't setup $$ during system() which
        # makes it impossible to detect if the handler was called from inside
        # the child.
        #
        # Instead, just ignore any warnings during the system(). Thanks to
        # mauke in #perl on Freenode (2013-10-29 23:30 CET) for the idea to
        # use no warnings and anno for testing a more recent Perl version with
        # a working $$.
        no warnings;

        my @cmd = map { $screen->encode($_) } @{$cmd};
        system { $cmd[0] } @cmd;
    };
    if ($exit != 0) {
        my $msg;
        if ($? == -1) {
            $msg = 'failed to execute: ' . $!;
        } elsif ($? & 127) {
            $msg = 'killed by signal ' . ($? & 127);
        } else {
            $msg = 'exited with code ' . ($? >> 8);
        }
        die "system(@{$cmd}) $msg.";
    }
    return;
}
sub run_in_background {
    my ($screen, $sub) = @_;

    $screen->debug('run_in_background', "running $sub");

    my $pid = fork;
    defined $pid or die $!;

    if ($pid == 0) {
        # The terminal multiplexer sends a SIGHUP to the process when it
        # closes the window (because the parent process has exited).
        local $SIG{HUP} = 'IGNORE';

        # Necessary for GNU screen or it'll keep the window open until the
        # paste command has run.
        close STDIN  or die $!;
        close STDOUT or die $!;
        close STDERR or die $!;

        # Double-fork to prevent zombies.
        my $pid = fork;
        defined $pid or die $!;
        if ($pid == 0) { # child
            $sub->();
        }
        exit;
    }
    waitpid $pid, 0 or die $!;
    return;
}


sub select_match {
    my ($name, $screen, $config, $input, $matches) = @_;

    $screen->debug('select_match', 'started');

    return if @{$matches} == 0;
    # Don't return on initial run to give the user a chance to select another
    # mode, e.g. to switch from URL selection to search selection.
    if (@{$matches} == 1 and not $config->{state}{initial}) {
        return { match => $matches->[0] };
    }
    $config->{state}{initial} = 0;

    my @sorted = sort { $b->{y} <=> $a->{y} or $b->{x} <=> $a->{x} } @{$matches};

    my $i = 1;
    foreach (@sorted) {
        $_->{id} = $i++;
    }

    $screen->prompt(name => $name, value => undef);
    $screen->draw_prompt($config);

    $screen->draw_matches($config, [], $matches);
    $screen->refresh;

    my $number = 0;
    while (1) {
        my $char = $screen->getch;
        if ($char =~ /^\d$/) {
            $number = $number * 10 + $char;
        } elsif ($char eq "\b" or $char eq "\x7f") { # backspace
            $number = int($number / 10);
        } elsif ($char eq "\n") {
            if ($number == 0) { # number without selection matches last entry
                $number = 1;
            }
            last;

        # Selecting a new mode requires falling through into the main input
        # loop and then starting the new mode.
        } elsif (defined $config->{mapping}{mode}{$char}) {
            $screen->draw_matches($config, $matches, []); # clear matches
            return { key => $char };
        # All other mappings stay in the current mode.
        } elsif (defined (my $m = $config->{mapping}{simple}{$char})) {
            $m->($char, $screen, $config, $input);
            next;

        } else {
            next; # ignore unknown mappings
        }

        last if $number > 0 and $number * 10 > @{$matches}; # unique match

        my @remaining = $number == 0
                      ? @{$matches}
                      : grep { $_->{id} =~ /^$number/ } @{$matches};
        $screen->draw_matches($config, $matches, \@remaining);
        $screen->refresh;
    }

    $screen->draw_matches($config, $matches, []); # remove matches

    foreach (@{$matches}) {
        return { match => $_ } if $_->{id} == $number;
    }
    $screen->debug('select_match', 'no match selected');
    return { match => undef };
}

sub extend_match_regex_left {
    my ($line, $match, $regex) = @_;

    my $s = reverse substr $line, 0, $match->{x};
    if ($s =~ /^($regex)/) {
        $match->{string}  = reverse($1) . $match->{string};
        $match->{x}      -= length $1;
        $match->{offset} -= length $1;
    }
    return;
}
sub extend_match_regex_right {
    my ($line, $match, $regex) = @_;

    my $s = substr $line, $match->{x} + length $match->{string};
    if ($s =~ /^($regex)/) {
        $match->{string} .= $1;
    }
    return;
}
sub extend_match {
    my ($screen, $config, $input, $match) = @_;

    $screen->debug('extend_match', 'started');

    return if not defined $match;

    $screen->prompt(name => 'extend', value => undef);
    $screen->draw_prompt($config);

    delete $match->{id}; # don't draw any match ids
    $screen->draw_matches($config, [], [$match]);
    $screen->refresh;

    my $line = $input->{lines}[$match->{y}];

    while (1) {
        my $match_old = \%{$match};

        my $char = $screen->getch;
        if ($char eq "\n") { # accept match
            last;

        } elsif ($char eq 'w') { # select current word (both directions)
            extend_match_regex_left($line,  $match, qr/\w+/);
            extend_match_regex_right($line, $match, qr/\w+/);
        } elsif ($char eq 'b') { # select current word (only left)
            extend_match_regex_left($line,  $match, qr/\w+/);
        } elsif ($char eq 'e') { # select current word (only right)
            extend_match_regex_right($line, $match, qr/\w+/);

        } elsif ($char eq 'W') { # select current WORD (both directions)
            extend_match_regex_left($line,  $match, qr/\S+/);
            extend_match_regex_right($line, $match, qr/\S+/);
        } elsif ($char eq 'B') { # select current WORD (only left)
            extend_match_regex_left($line,  $match, qr/\S+/);
        } elsif ($char eq 'E') { # select current WORD (only right)
            extend_match_regex_right($line, $match, qr/\S+/);

        } elsif ($char eq '^') { # select to beginning of line
            extend_match_regex_left($line, $match, qr/.+/);
        } elsif ($char eq '$') { # select to end of line
            extend_match_regex_right($line, $match, qr/.+/);

        # Allow mode changes if not overwritten by local mappings.
        } elsif (defined $config->{mapping}{mode}{$char}) {
            $screen->draw_matches($config, [$match_old], []); # clear match
            return { key => $char };

        } else {
            next; # ignore unknown mappings
        }

        $screen->draw_matches($config, [$match_old], [$match]);
        $screen->refresh;
    }

    $screen->debug('extend_match', 'done');

    return { match => $match };
}


sub mapping_paste {
    my ($key, $screen, $config, $input) = @_;

    $screen->debug('mapping_paste', 'started');

    $config->{state}{handler} = $config->{handler}{paste};

    $screen->prompt(flags => 'P'); # paste
    $screen->draw_prompt($config);
    $screen->refresh;

    return {};
}
sub mapping_yank {
    my ($key, $screen, $config, $input) = @_;

    $screen->debug('mapping_yank', 'started');

    $config->{state}{handler} = $config->{handler}{yank};

    $screen->prompt(flags => 'Y'); # yank
    $screen->draw_prompt($config);
    $screen->refresh;

    return {};
}


=head2 NORMAL MODES

Normal modes select matches by calling a function which returns them, e.g. by
using a regex.

The following normal modes are available:

=over 4

=item B<path mode> select relative/absolute paths

=item B<url mode>  select URLs

=back

=cut
sub mapping_mode_path {
    my ($key, $screen, $config, $input) = @_;

    $screen->debug('mapping_mode_path', 'started');

    my @matches = get_regex_matches($input, $config->{regex}{path});
    return {
        select  => 'path select',
        matches => \@matches,
        handler => $config->{handler}{yank},
    };
}
sub mapping_mode_url {
    my ($key, $screen, $config, $input) = @_;

    $screen->debug('mapping_mode_url', 'started');

    my @matches = get_regex_matches($input, $config->{regex}{url});
    return {
        select  => 'url select',
        matches => \@matches,
        handler => $config->{handler}{url},
    };
}

=head2 SEARCH MODE (AND EXTEND MODE)

Search mode is a special mode which lets you type a search string (a Perl
regex) and then select one of the matches. Afterwards you can extend the
match. For example select the complete word or to the end of the line. This
allows quick selection of arbitrary text.

The following mappings are available during the extension mode (not
configurable at the moment):

=over 4

=item B<w> select current word

=item B<b> extend word to the left

=item B<e> extend word to the right

=item B<W> select current WORD

=item B<B> extend WORD to the left

=item B<E> extend WORD to the right

=item B<^> extend to beginning of line

=item B<$> extend to end of line

=back

C<word> includes any characters matching C<\w+>, C<WORD> any non-whitespace
characters (C<\S+>), just like in Vim.

=cut
sub mapping_mode_search {
    my ($key, $screen, $config, $input) = @_;

    $screen->debug('mapping_mode_search', 'started');

    $screen->cursor(1);

    my $search = ''; # encoded
    my @last_matches;
    while (1) {
        # getch doesn't return decoded characters but raw input bytes. Wait
        # until the input character is complete.
        my $value = $screen->decode($search);
        $value = '' unless defined $value; # undef on decode failure

        $screen->prompt(name => 'search', value => $value);
        $screen->draw_prompt($config);
        $screen->refresh;

        my $char = $screen->getch;
        # TODO: readline editing support
        if ($char eq "\n") {
            last;
        } elsif ($char eq "\b" or $char eq "\x7f") { # backspace
            # Remove a character, not a byte.
            $search = $screen->decode($search);
            chop $search;
            $search = $screen->encode($search);
        } else {
            $search .= $char;
            next unless defined $screen->decode($search);
        }

        my @matches;
        if ($search ne '') {
            my $case = '';
            if (($config->{setting}{smartcase} and $search eq lc $search)
                    or $config->{setting}{ignorecase}) {
                $case = '(?i)';
            }
            # Ignore invalid regexps.
            # TODO: display warning on error?
            eval {
                @matches = get_regex_matches($input, qr/($case$search)/);
            };
        }
        $screen->draw_matches($config, \@last_matches, \@matches);
        @last_matches = @matches;
    }

    $screen->cursor(0);

    return {
        select  => 'search',
        matches => \@last_matches,
        extend  => 1,
        handler => $config->{handler}{yank},
    };
}

sub mapping_quit {
    my ($key, $screen, $config, $input) = @_;

    # Key is necessary to fall through to main event loop which then quits.
    return { key => $key, quit => 1 };
}


sub handler_yank {
    my ($screen, $config, $match) = @_;

    $screen->debug('handler_yank', 'started');

    require File::Temp;

    # Use a temporary file to prevent leaking the yanked data to other users
    # with the command line, e.g. ps aux or top.
    my ($fh, $tmp) = File::Temp::tempfile(); # dies on its own
    print $fh $screen->encode($match->{value});
    close $fh or die $!;

    if ($config->{setting}{multiplexer} eq 'screen') {
        $screen->debug('handler_yank', 'using screen');

        # GNU screen displays an annoying "Slurping X characters into buffer".
        # Use 'msgwait 0' as a hack to disable it.
        my $msgwait = $config->{setting}{screen_msgwait};
        run_command($screen, $config, ['screen', '-X', 'msgwait', 0]);
        run_command($screen, $config, ['screen', '-X', 'readbuf', $tmp]);
        run_command($screen, $config, ['screen', '-X', 'msgwait', $msgwait]);
    } elsif ($config->{setting}{multiplexer} eq 'tmux') {
        $screen->debug('handler_yank', 'using tmux');

        run_command($screen, $config, ['tmux', 'load-buffer', $tmp]);
    } else {
        die 'unsupported multiplexer';
    }

    unlink $tmp or die $!;
    return;
}
sub handler_paste {
    my ($screen, $config, $match) = @_;

    $screen->debug('handler_paste', 'started');

    require Time::HiRes;

    my @cmd;
    if ($config->{setting}{multiplexer} eq 'screen') {
        $screen->debug('handler_paste', 'using screen');
        @cmd = qw( screen -X paste . );
    } elsif ($config->{setting}{multiplexer} eq 'tmux') {
        $screen->debug('handler_paste', 'using tmux');
        @cmd = qw( tmux paste-buffer );
    } else {
        die 'unsupported multiplexer';
    }

    run_in_background($screen, sub {
        # We need to get the data in the paste buffer before we can paste
        # it.
        handler_yank($screen, $config, $match);

        # Sleep until we switch back to the current window.
        Time::HiRes::usleep($config->{setting}{paste_sleep});

        run_command($screen, $config, \@cmd);
    });
    return;
}
sub handler_url {
    my ($screen, $config, $match) = @_;

    $screen->debug('handler_url', "opening $match->{value}");

    run_in_background($screen, sub {
        my @cmd = ( @{$config->{setting}{browser}}, $match->{value} );
        run_command($screen, $config, \@cmd);
    });
    return;
}



# CONFIGURATION DEFAULTS

=head1 CONFIGURATION

fcscs is configured through F<~/.fcscsrc> or F<~/.config/fcscs/fcscsrc> which
is a normal Perl script with all of Perl's usual features.

All configuration values are stored in the hash C<%config>. All manually
defined keys overwrite the default settings.

A simple F<~/.fcscsrc> could look like this (for details about the used
settings see below):

    use strict;
    use warnings;

    use Curses; # for COLOR_* and A_* constants

    our %config;

    # Draw matches in blue.
    $config{attribute}{match_string} = color_pair(COLOR_BLUE, -1);
    # Enable Vim-like 'smartcase', ignore case until an upper character is
    # searched.
    $config{setting}{smartcase} = 1;

    # Use chromium to open URLs if running under X, elinks otherwise.
    if (defined $ENV{DISPLAY}) {
        $config{setting}{browser} = ['chromium'];
    } else {
        $config{setting}{browser} = ['elinks'];
    }

    # Let fcscs know the file was loaded successfully.
    1;

=cut


if (@ARGV != 1) {
    require Pod::Usage;
    Pod::Usage::pod2usage(2);
}


# Determine terminal encoding from the environment ($ENV{LANG} or similar).
my $encoding = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET);

my $screen = Screen->init($encoding);

# We must restore the screen before exiting.
local $SIG{INT} = sub {
    $screen->deinit;
    exit 128 + 2;
};
# Make all warnings fatal to make sure they don't get lost (stderr is normally
# not displayed).
local $SIG{__WARN__} = sub {
    $screen->die('warning', @_);
};



=head2 MAPPINGS

I<NOTE>: Mappings are split in two categories: Mode mappings which change the
selection and may receive additional input (e.g. a search string) and simple
mappings which only change some value. Mode mappings are configured via
C<$config{mapping}{mode}>, simple mappings via C<$config{mapping}{simple}>.

The following mode mappings are available by default (the function to remap
them in parentheses):

=over

=item B<f> select absolute/relative paths (C<\&mapping_mode_path>)

=item B<u> select URLs (C<\&mapping_mode_url>)

=item B</> search for regex to get selection (C<\&mapping_mode_search>)

=item B<q> quit fcscs (C<\&mapping_quit>)

=back

The following simple mappings are available by default:

=over

=item B<p> enable pasting (C<\&mapping_paste>)

=item B<y> enable yanking (copying) (C<\&mapping_yank>)

=back

All (single-byte) keys except numbers, backspace and return can be mapped.

Unknown mappings are ignored when pressing keys.

To remove a default mapping, delete it from the mapping hash.

Example:

    # Map 'p' to select paths, 'P' to enable pasting.
    $config{mapping}{mode}{p} = \&mapping_mode_path;
    $config{mapping}{simple}{P} = \&mapping_paste;

    # Disable 'f' mapping.
    delete $config{mapping}{mode}{f};

=cut
my %mapping_mode = (
    f   => \&mapping_mode_path,
    u   => \&mapping_mode_url,
    '/' => \&mapping_mode_search,
    q   => \&mapping_quit,
);
my %mapping_simple = (
    p => \&mapping_paste,
    y => \&mapping_yank,
);

=head2 ATTRIBUTES

Attributes are used to style the output. They must be Curses attributes.
Defaults in parentheses (foreground, background, attribute).

=over

=item B<match_id>      attribute for match numbers (red, default, bold)

=item B<match_string>  attribute for matches (yellow, default, normal)

=item B<match_last>    attribute for the match selected by return (yellow, default, underline)

=item B<prompt_name>   attribute for prompt name (standout)

=item B<prompt_flags>  attribute for prompt flags (standout)

=back

Example:

    # Draw prompt flags in bold red with default background color.
    $config{attribute}{prompt_flags}
        = Curses::A_BOLD
        | color_pair(Curses::COLOR_RED, -1);

=cut
my %attribute = (
    match_id     => $screen->color_pair(Curses::COLOR_RED, -1)
                    | Curses::A_BOLD,
    match_string => $screen->color_pair(Curses::COLOR_YELLOW, -1),
    match_last   => $screen->color_pair(Curses::COLOR_YELLOW, -1)
                    | Curses::A_UNDERLINE,
    prompt_name  => Curses::A_STANDOUT,
    prompt_flags => Curses::A_STANDOUT,
);

=head2 SETTINGS

Defaults in parentheses.

=over

=item B<debug>          enable debug mode, writes to I<~/.config/fcscs/log> (C<0>)

=item B<initial_mode>   start in this mode, must be a valid mode mapping (C<\&mapping_mode_url>)

=item B<multiplexer>    set multiplexer ("screen" or "tmux") if not autodetected (C<undef>)

=item B<ignorecase>     ignore case when searching (C<0>)

=item B<smartcase>      ignore case unless one uppercase character is searched (C<1>)

=item B<paste_sleep>    sleep x us before running paste command (C<100_000>)

=item B<screen_msgwait> GNU Screen's msgwait variable, used when yanking (C<5>)

=item B<browser>        browser command as array reference (C<['x-www-browser']>)

=back

Example:

    # Select paths on startup instead of URLs.
    $config{setting}{initial_mode} = \&mapping_mode_path;

=cut
my %setting = (
    # options
    debug          => 0,
    initial_mode   => \&mapping_mode_url,
    multiplexer    => undef,
    ignorecase     => 0,
    smartcase      => 1,
    paste_sleep    => 100_000,
    screen_msgwait => 5,
    # commands
    browser        => ['x-www-browser'],
);

=head2 REGEXPS

=over

=item B<url>  used by C<\&mapping_mode_url()>

=item B<path> used by C<\&mapping_mode_path()>

=back

Example:

    # Select all non-whitespace characters when searching for paths.
    $config{regex}{path} = qr{(\S+)};

=cut
my %regex = (
    # Taken from urlview's default configuration file, thanks.
    url  => qr{((?:(?:(?:http|https|ftp|gopher)|mailto):(?://)?[^ <>"\t]*|(?:www|ftp)[0-9]?\.[-a-z0-9.]+)[^ .,;\t\n\r<">\):]?[^, <>"\t]*[^ .,;\t\n\r<">\):])},
    path => qr{(~?[a-zA-Z0-9_./-]*/[a-zA-Z0-9_./-]+)},
);

=head2 HANDLERS

Handlers are used to perform actions on the selected string.

The following handlers are available, defaults in parentheses.

=over

=item B<yank>  used to yank (copy) selection to paste buffer (C<\&handler_yank>)

=item B<paste> used to paste selection into window (C<\&handler_paste>)

=item B<url>   used to open URLs (e.g. in a browser) (C<\&handler_url>)

=back

Example:

    # Download YouTube videos with a custom wrapper, handle all other URLs
    # with the default URL handler.
    $config{handler}{url} = sub {
        my ($screen, $config, $match) = @_;

        if ($match->{value} =~ m{^https://www.youtube.com/}) {
            return run_in_background($screen, sub {
                run_command($screen, $config,
                            ['youtube-dl-wrapper', $match->{value}]);
            });
        }
        handler_url(@_);
    };

=cut
my %handler = (
    yank  => \&handler_yank,
    paste => \&handler_paste,
    url   => \&handler_url,
);

my %state = (
    initial => 1, # used by select_match() for 'initial_mode'
    handler => undef,
);



# CONFIGURATION "API"

=head2 FUNCTIONS

The following functions are available:

    color_pair($fg, $bg)

Create a new Curses attribute with the given fore- and background color.

    mapping_mode_path()
    mapping_mode_url()
    mapping_mode_search()

    mapping_paste()
    mapping_yank()
    mapping_quit()

Used as mappings, see L</MAPPINGS> above.

    handler_yank()
    handler_paste()
    handler_url()

Used as handler to yank, paste selection or open URL in browser.

    debug()
    get_regex_matches()
    select_match()
    run_command()
    run_in_background()

Helper functions when writing custom mappings, see the source for details.

Example:

    TODO

=cut

# All variables and functions which are usable by ~/.fcscsrc.
package Fcscs {
    our $screen; # "private"
    our %config;

    sub color_pair { return $screen->color_pair(@_); }

    sub mapping_mode_path { return main::mapping_mode_path(@_); }
    sub mapping_mode_url { return main::mapping_mode_url(@_); }
    sub mapping_mode_search { return main::mapping_mode_search(@_); }

    sub mapping_paste { return main::mapping_paste(@_); }
    sub mapping_yank { return main::mapping_yank(@_); }
    sub mapping_quit { return main::mapping_quit(@_); }

    sub handler_yank { return main::handler_yank(@_); }
    sub handler_paste { return main::handler_paste(@_); }
    sub handler_url { return main::handler_url(@_); }

    sub debug { return main::debug(@_); }

    sub get_regex_matches { return main::get_regex_matches(@_); }
    sub select_match { return main::select_match(@_); }

    sub run_command { return main::run_command(@_); }
    sub run_in_background { return main::run_in_background(@_); }
}
$Fcscs::screen = $screen;



# LOAD USER CONFIG

# Alias %config and %Fcscs::config. %config is less to type.
our %config;
local *config = \%Fcscs::config;

$config{mapping}{mode}   = \%mapping_mode;
$config{mapping}{simple} = \%mapping_simple;
$config{attribute}       = \%attribute;
$config{setting}         = \%setting;
$config{regex}           = \%regex;
$config{handler}         = \%handler;
$config{state}           = \%state;

package Fcscs {
    my @configs = ("$ENV{HOME}/.fcscsrc",
                   "$ENV{HOME}/.config/fcscs/fcscsrc");
    foreach my $path (@configs) {
        my $decoded = $screen->decode($path);

        # Load configuration file. Checks have a race condition if the home
        # directory is writable by an attacker (but then the user is screwed
        # anyway).
        next unless -e $path;
        if (not -O $path) {
            $screen->die("Config '$decoded' not owned by current user!");
        }
        # Make sure the file is not writable by other users. Doesn't handle
        # ACLs and see comment above about race conditions.
        my @stat = stat $path or die $!;
        my $mode = $stat[2];
        if (($mode & Fcntl::S_IWGRP) or ($mode & Fcntl::S_IWOTH)) {
            die "Config '$decoded' must not be writable by other users.";
        }

        my $result = do $path;
        if (not $result) {
            $screen->die("Failed to parse '$decoded': $@") if $@;
            $screen->die("Failed to do '$decoded': $!") unless defined $result;
            $screen->die("Failed to run '$decoded'.");
        }

        last; # success, don't load more files
    }
}
$screen->{debug} = $config{setting}{debug};


# MAIN

eval {
    # Auto-detect current multiplexer.
    if (not defined $config{setting}{multiplexer}) {
        if (defined $ENV{STY} and defined $ENV{TMUX}) {
            die 'Found both $STY and $TMUX, set $config{setting}{multiplexer}.';
        } elsif (defined $ENV{STY}) {
            $config{setting}{multiplexer} = 'screen';
        } elsif (defined $ENV{TMUX}) {
            $config{setting}{multiplexer} = 'tmux';
        } else {
            die 'No multiplexer found.';
        }
    }

    my $binmode = $encoding;
    # GNU screen stores the screen dump for unknown reasons as ISO-8859-1
    # instead of the currently active encoding.
    if ($config{setting}{multiplexer} eq 'screen') {
        $binmode = 'ISO-8859-1';
    }

    my @input_lines;
    open my $fh, '<', $ARGV[0] or die $!;
    binmode $fh, ":encoding($binmode)" or die $!;
    while (<$fh>) {
        chomp;
        push @input_lines, $_;
    }
    close $fh or die $!;

    my $input = prepare_input($screen, \@input_lines);

    # Display original screen content.
    my $y = 0;
    foreach (@{$input->{lines}}) {
        $screen->draw_simple($y++, 0, undef, $_);
    }
    $screen->refresh;


    my $mapping = $config{setting}{initial_mode};

    my $key;
    while (1) {
        if (not defined $mapping) {
            $key = $screen->getch unless defined $key;
            $screen->debug('input', "got key '$key'");

            $mapping = $config{mapping}{mode}{$key};
            $mapping = $config{mapping}{simple}{$key} unless defined $mapping;
            if (not defined $mapping) { # ignore unknown mappings
                $key = undef;
                next;
            }
        }

        $screen->debug('input', 'running mapping');
        my $result = $mapping->($key, $screen, \%config, $input);
        $mapping = undef;

RESULT:
        if (defined $result->{quit}) {
            $screen->debug('input', 'quitting');
            last;
        }
        if (defined $result->{key}) {
            $key = $result->{key}; # lookup another mapping
            $screen->debug('input', "processing new key: '$key'");
            next;
        }
        if (defined $result->{select}) {
            $screen->debug('input', 'selecting match');
            my $tmp = $result;
            $result = select_match($result->{select},
                                   $screen, \%config, $input,
                                   $result->{matches});
            $result->{handler} = $tmp->{handler};
            $result->{extend}  = $tmp->{extend};
            goto RESULT; # reprocess special entries in result
        }
        if (defined $result->{extend}) {
            $screen->debug('input', 'extending match');
            $result = extend_match($screen, \%config, $input,
                                   $result->{match});
            goto RESULT; # reprocess special entries in result
        }
        if (defined $result->{match}) {
            if (not defined $result->{match}{value}) {
                $result->{match}{value} = $result->{match}{string};
            }

            $screen->debug('input', 'running handler');

            # Choose handler with falling priority.
            my @handlers = (
                $config{state}{handler},     # set by user
                $result->{match}{handler},   # set by match
                $result->{handler},          # set by mapping
                $config{handler}{yank},      # fallback
            );
            foreach my $handler (@handlers) {
                next unless defined $handler;

                $handler->($screen, \%config, $result->{match});
                last;
            }
            last;
        }

        $key = undef; # get next key from user
    }
};
if ($@) {
    $screen->die("$@");
}

$screen->deinit;

__END__

=head1 EXIT STATUS

=over 4

=item B<0>

Success.

=item B<1>

An error occurred.

=item B<2>

Invalid arguments/options.

=back

=head1 AUTHOR

Simon Ruderich E<lt>simon@ruderich.orgE<gt>

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2013-2016 by Simon Ruderich

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see E<lt>http://www.gnu.org/licenses/E<gt>.

=head1 SEE ALSO

L<screen(1)>, L<tmux(1)>, L<urlview(1)>

=cut