#!/usr/bin/env perl
# -*- perl -*-

use strict;
use warnings;
use FindBin;
use lib "$FindBin::RealBin/..";

use Cwd qw(cwd);
use Getopt::Long;
use Tk;
use Tk::PNG;
use Tk::ROText;

use BBBikeUtil qw(bbbike_root is_in_path);

use constant MAX_GREP_WORD_LENGTH => 512;

my $bbbike_root = bbbike_root;
chdir "$bbbike_root/data" or warn "WARN: can't change to bbbike's data directory ($!), continue running nevertheless.\n";

my $refresh_interval = 1;
my $auto_update_from_selection = 0;
my $auto_update_off_seconds = 3600;
my $auto_update_from_file = 0; # XXX currently cannot be enabled by option
my $current_url_filename;
my $stay_on_top = 1;
my $debug;

my @add_bbbike_grep;
# XXX maybe make the following conditional?
for my $add_org_file ("$ENV{HOME}/src/bbbike-aux/tmp/bplan.org") {
    if (-r $add_org_file) {
	push @add_bbbike_grep, '--add-org-file', $add_org_file;
    }
}
for my $add_plain_file ("$ENV{HOME}/backup/changedetection.io/url-watches.json") {
    if (-r $add_plain_file) {
	push @add_bbbike_grep, '--add-file-with-encoding', $add_plain_file.':utf-8';
    }
}

# XXX actually it would be good if we could determine which emacs is available,
# and switch on/off the bug handling
my $WORKAROUND_EMACS_24_BUG = 1;

my $mw = MainWindow->new;
$mw->title("BBBike Grep");

GetOptions(
    "refresh-interval=f" => \$refresh_interval,
    "auto-update-from-selection!" => \$auto_update_from_selection,
    "auto-update-off=i" => \$auto_update_off_seconds,
    "current-url-hack=s" => \$current_url_filename,
    "stay-on-top!" => \$stay_on_top,
    "debug" => \$debug,
)
    or die <<EOF;
usage: $0 [tk options] [--refresh-interval seconds]
	[--auto-update-from-selection] [--auto-update-off-seconds seconds]
	[--current-url-hack filename]
	[--stay-on-top] [--debug]
EOF

my $top_frame;
Tk::grid(
    ($top_frame = $mw->Frame),
    -sticky => 'ew',
);
$top_frame->Label(-text => "Grep BBBike data:")->pack(-side => 'left');
my $grep_entry = $top_frame->Entry->pack(-side => 'left', -fill => 'x', -expand => 1);
$grep_entry->insert("end", "Brandenburger Tor");
my $grep_button = $top_frame->Button(-text => "Grep", -command => \&run_grep)->pack(-side => 'left');
$grep_entry->bind('<Return>' => sub { $grep_button->invoke });

my $emacs_p = do {
    my $emacs_icon_file = get_emacs_icon();
    if (defined $emacs_icon_file) {
	$mw->Photo(-file => $emacs_icon_file);
    } else {
	undef;
    }
};
my $bbbike_p = do {
    my $bbbike_icon_file = get_bbbike_icon();
    if (defined $bbbike_icon_file) {
	$mw->Photo(-file => $bbbike_icon_file);
    } else {
	undef;
    }
};

Tk::grid(
    $mw->Checkbutton(-text => "Auto Update from Selection", -variable => \$auto_update_from_selection, -command => \&toggle_update),
    -sticky => 'w',
);
my $timer;

my $text_row = 2;
if ($current_url_filename) {
    Tk::grid(
	$mw->Checkbutton(-text => "Auto Update from special file", -variable => \$auto_update_from_file, -command => \&toggle_update_from_file),
	-sticky => 'w',
    );
    $text_row++;
}
my $timer_from_file;

my $rotext;
Tk::grid(
    ($rotext = $mw->Scrolled('ROText', -height => 10, -wrap => 'none', -scrollbars => 'soe')),
    -sticky => 'nsew',
);
# Note: please adapt also flash_rotext if changing or adding here new coloring tags
$rotext->tagConfigure('removedItem', -background => '#ffcccc', -foreground => 'black');
$rotext->tagConfigure('activeItem',  -background => '#ccffcc', -foreground => 'black');

# make sure everything is horizontally expanded (only one column)
$mw->gridColumnconfigure($_, -weight => 1) for (0);
# make sure the rotext is expanding also vertically
$mw->gridRowconfigure($_, -weight => 1) for ($text_row);

if ($auto_update_from_selection) {
    toggle_update();
}

# XXX does not work on fvwm2, but with other window managers
if ($stay_on_top && is_in_path 'wmctrl') {
    $mw->update;
    my $hex_win_id = sprintf "0x%x", ($mw->wrapper)[0];
    my @cmd = ('wmctrl', ($debug ? ('-v') : ()), '-i', '-r', $hex_win_id, '-b', 'add,above');
    warn "Run: @cmd\n" if $debug;
    system @cmd;
    warn "@cmd failed (for stay on top): $?" if $? != 0;
}

MainLoop;

# Function to run grep command
sub run_grep {
    my $grep_word = $grep_entry->get;
    my $term_type_opt = '--fixed';
    if ($grep_word =~ m{^\(.+\|.+\)$} && eval { qr{$grep_word} }) { # heuristic: looks like a regexp with multiple alternatives, and it is a valid regexp
	$term_type_opt = '--rx';
	# no length check & snipping done for regexps
    } else {
	if (length $grep_word > MAX_GREP_WORD_LENGTH) {
	    warn "WARNING: word to search for is too long (" . length($grep_word) . " characters), snipped to " . MAX_GREP_WORD_LENGTH . "\n";
	    $grep_word = substr($grep_word, 0, MAX_GREP_WORD_LENGTH);
	}
    }
	
    # XXX -limit 100 may be too small: /bahnhofstr/ has currently 317 matches
    my @cmd = ("$bbbike_root/miscsrc/bbbike-grep", $term_type_opt, "-limit", 100, "-reldir", cwd(), "--byte-offset", @add_bbbike_grep, "--", $grep_word);
    #warn "@cmd";
    open my $fh, '-|', @cmd or die $!;
    binmode $fh, ':utf8';
    my @output = <$fh>;
    $rotext->delete('1.0', 'end');
    my $result_lines = 0;
    foreach my $line (@output) {
#warn "<$line>";
        if ($line =~ /^(.*?):(\d+):(.*)$/) {
            my $filename = $1;
            my $byte_offset = $2;
            my $matching_text = $3;

	    my $emacs_button = $rotext->Button(
		-image => $emacs_p,
	        -text => 'E',
                -command => sub { call_emacsclient_with_byte_offset($filename, $byte_offset) },
		-pady => 0,
	    );
	    $rotext->windowCreate('end', -window => $emacs_button);
	    $rotext->insert('end', ' ') unless $emacs_p;

	    my $bbbike_button = $rotext->Button(
		-image => $bbbike_p,
	        -text => 'B',
		-pady => 0,
	    );
	    my ($coordinate_pairs) = $matching_text =~ /\s(-?\d+,-?\d+(?:\s+-?\d+,-?\d+)*)(?:\s|$)/;
	    if ($coordinate_pairs) {
		$bbbike_button->configure(-command => sub { call_bbbikeclient($coordinate_pairs) });
	    } else {
		$bbbike_button->configure(-state => 'disabled');
	    }
	    $rotext->windowCreate('end', -window => $bbbike_button);
	    $rotext->insert('end', ' ') unless $bbbike_p;

	    my @tag;
	    if ($matching_text =~ /^#\s*REMOVED/) {
		@tag = 'removedItem';
	    } elsif ($matching_text =~ /^INACTIVE:/) {
		@tag = 'removedItem';
	    } else {
		@tag = 'activeItem';
	    }

	    (my $displayed_filename = $filename) =~ s/-orig//;
            $rotext->insert('end', "$displayed_filename\t$matching_text\n", @tag);
	    $result_lines++;
        }
    }
    flash_rotext($result_lines == 0 ? 'red' : 'green');
}

{
    my $timer_id;
    sub flash_rotext {
	my($color) = @_;
	return if $timer_id && $rotext->afterInfo($timer_id);
	my @original_colors = ($rotext->cget('-background'), $rotext->tagCget('removedItem', '-background'), $rotext->tagCget('activeItem', '-background'));
	$rotext->configure(-background                   => $color);
	$rotext->tagConfigure('removedItem', -background => $color);
	$rotext->tagConfigure('activeItem',  -background => $color);
	$timer_id = $rotext->after(500, sub {
				   $rotext->configure(-background                   => shift @original_colors);
				   $rotext->tagConfigure('removedItem', -background => shift @original_colors);
				   $rotext->tagConfigure('activeItem',  -background => shift @original_colors);
				   undef $timer_id;
			       });
    }
}

sub call_emacsclient {
    my($filename, $line_number) = @_;
    # Call emacsclient with filename and line number
    my @cmd = ('emacsclient', '-n', "+$line_number", $filename);
    warn "Run: @cmd" if $debug;
    system(@cmd);
}

sub call_emacsclient_with_byte_offset {
    my($filename, $byte_offset) = @_;
    my $is_org_mode_file = $filename =~ /\.org$/;
    my $emacs_position = $byte_offset + 1;
    my $unfold_code = $is_org_mode_file ? ' (org-show-entry)' : '';
    my $eval_code;
    if ($WORKAROUND_EMACS_24_BUG) {
	my $is_single_byte_encoding;
	if ($is_org_mode_file) { # org-mode files usually utf-8
	    $is_single_byte_encoding = 0;
	} else {
	    if (open my $fh, $filename) {
		my $first_line = <$fh>;
		if ($first_line !~ /utf-?8/i) { # just a heuristic to detect single byte encoding
		    $is_single_byte_encoding = 1;
		} else {
		    $is_single_byte_encoding = 0;
		}
	    }
	}
	if ($is_single_byte_encoding) {
	    $eval_code = qq{(progn (find-file "$filename") (goto-char $emacs_position) (x-focus-frame nil)$unfold_code)}; # XXX do not use byte-to-position, see https://debbugs.gnu.org/cgi/bugreport.cgi?bug=20783
	}
    }
    if (!$eval_code) {
	$eval_code = qq{(progn (find-file "$filename") (goto-char (byte-to-position $emacs_position)) (x-focus-frame nil)$unfold_code)};
    }
    my @cmd = ('emacsclient', '-n', '-e', $eval_code);
    warn "Run: @cmd" if $debug;
    if (eval { require IPC::Run; 1 }) {
	IPC::Run::run(\@cmd, '>', '/dev/null'); # suppress output, as emacsclient -e will print the return value to stdout
    } else {
	system(@cmd);
    }
}

sub call_bbbikeclient {
    my($coordinate_pairs) = @_;
    my @cmd = ("$bbbike_root/bbbikeclient", "-centerc", $coordinate_pairs, "-mark");
    warn "Run: @cmd" if $debug;
    system(@cmd);
}

my $last_update_change;

# Function to toggle regular updating
sub toggle_update {
    if ($auto_update_from_selection) {
	$last_update_change = time; # init
        update_selection_content();
        $timer = $mw->repeat($refresh_interval * 1000, [\&update_selection_content]);
    } else {
        $mw->afterCancel($timer) if defined $timer;
    }
}

my $last_update_from_file_change;
sub toggle_update_from_file {
    if ($auto_update_from_file) {
	$last_update_from_file_change = time; # init
        update_file_content();
        $timer_from_file = $mw->repeat($refresh_interval * 1000, [\&update_file_content]);
    } else {
        $mw->afterCancel($timer_from_file) if defined $timer_from_file;
    }
}

{
    my $old_selection_content = '';
    sub update_selection_content {
	my $selection_content;
	eval {
	    $selection_content = $mw->SelectionGet(-selection => 'PRIMARY');
	};
	if ($@) {
	    $selection_content = "";
	    return;
	}
	if ($selection_content =~ /^(?:CHANGED|NEW|REMOVED|UNCHANGED|UNCHANGED, EXPIRED)\t.*\t([^\t]+)\t/) {
	    $selection_content = $1; # VIZ source_id
	    if ($selection_content =~ / /) { # new multiple ids
		$selection_content = [ split / /, $selection_content ];
	    }
	} else {
	    $selection_content =~ s/^\s+//; $selection_content =~ s/\s+$//; $selection_content =~ s/\s\s+/ /g; # trim
	    $selection_content =~ s/\n.*$//;  # Crop after the first line
	}
	if (ref $selection_content eq 'ARRAY') { # array of regexp terms
	    $selection_content = '(' . join('|', map { quotemeta } @$selection_content) . ')';
	} else {
	    return if $selection_content eq '';
	    $selection_content = url_normalizations($selection_content);
	    $selection_content = expand_short_link($selection_content);
	}
	if ($old_selection_content ne $selection_content) {
	    $last_update_change = time;
	    $old_selection_content = $selection_content;
	    $grep_entry->configure(-text => $selection_content);
	    run_grep();
	} else {
	    if ($auto_update_from_selection) {
		if ($last_update_change + $auto_update_off_seconds < time) {
		    warn "INFO: inactive user, disable Auto Update from Selection.\n";
		    $old_selection_content = ''; $auto_update_from_selection = 0; toggle_update();
		}
	    }
	}
    }
}

{
    my $old_file_content = '';
    sub update_file_content {
	my $mtime = (stat($current_url_filename))[9];
	if (!defined $mtime) {
	    warn "$current_url_filename has no mtime (probably non-existing?)\n" if $debug;
	    return;
	}
	if ($mtime <= $last_update_from_file_change) {
	    # too noisy: warn "$current_url_filename did not change ($mtime <= $last_update_from_file_change)\n" if $debug;
	    return;
	}

	my $fh;
	unless (open $fh, $current_url_filename) {
	    warn "ERROR: $current_url_filename is not readable, or maybe vanished in between (error: $!)\n";
	    return;
	}
	chomp(my $url = <$fh>);
	if ($url eq '') {
	    warn "No URL found in $current_url_filename\n" if $debug;
	    return;
	}
	if ($url eq 'about:blank') {
	    # ignore: this is shortly visible when creating a new tab
	    return;
	}
	$url = url_normalizations($url);

	if ($old_file_content ne $url) {
	    $last_update_from_file_change = $mtime;
	    $old_file_content = $url;
	    $grep_entry->configure(-text => $url);
	    run_grep();
	} else {
	    if ($auto_update_from_selection) {
		if ($last_update_from_file_change + $auto_update_off_seconds < time) {
		    warn "INFO: inactive user, disable Auto Update from special file.\n";
		    $old_file_content = ''; $auto_update_from_file = 0; toggle_update_from_file();
		}
	    }
	}
    }
}

sub get_emacs_icon {
    my @location_candidates = qw(
        /usr/share/icons/hicolor/16x16/apps/emacs.png
        /usr/share/emacs/*/etc/images/icons/hicolor/16x16/apps/emacs.png
    );

    for my $location_candidate (@location_candidates) {
        my @files = reverse glob $location_candidate;
        for my $file (@files) {
            if (-e $file) {
		return $file;
	    }
	}
    }

    undef;
}

sub get_bbbike_icon {
    my $f = "$bbbike_root/images/srtbike16a.png";
    return $f if -e $f;
}

sub url_normalizations {
    my $url = shift;
    # should be first
    $url =~ s{https://archive\.[a-z]+/o/[^/]+/}{};
    # Mostly for forum URLs, to remove the current page/article indication from the URL.
    $url =~ s{(https://www.deutsches-architekturforum.de/thread/\d+-).*}{$1};
    $url =~ s{(https://www.architektur-urbanistik.berlin/index.php\?threads/.*?/).*}{$1};
    $url =~ s{(https://www.bahninfo-forum.de/read.php\?\d+,\d+,).*}{$1};
    $url =~ s{(https://www.nd-aktuell.de/artikel/\d+\.).*}{$1};
    $url =~ s{(https://www.tagesspiegel.de/.*)\?.*}{$1};
    $url =~ s{(https://www.berlin.de/.*)\?ts=\d+\b}{$1};
    $url =~ s{https?://(?:www\.)?(entwicklungsstadt.de/.*)}{$1}; # remove www.
    # should be last
    $url =~ s{([&?])utm_source=.*?(?=&|$)}{$1 eq '?' ? '?' : ''}e;
    $url =~ s{\?$}{};
    $url;
}

{
    my $ua;
    sub _get_ua {
	return $ua if $ua;
	require LWP::UserAgent;
	$ua = LWP::UserAgent->new;
	$ua->timeout(10);
	$ua->requests_redirectable([]); # need to find out the Location header of redirects
	$ua;
    }
}

sub expand_short_link {
    my $url = shift;
    if ($url =~ m{^https://t\.co/}) {
	my $ua = _get_ua();
	my $resp = $ua->get($url);
	if (my $loc = $resp->header('location')) {
	    return $loc;
	}
    }
    $url;
}
