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

#
# Author: Slaven Rezic
#
# Copyright (C) 2003,2004,2007,2014,2017,2022,2023,2025 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: slaven@rezic.de
# WWW:  http://www.rezic.de/eserte/
#

package BBBike::check_bbbike_temp_blockings;

use strict;
use vars qw(@temp_blocking);
use v5.10.0; # ?<...>
use FindBin;
use Data::Dumper qw(Dumper);
use Getopt::Long;
use POSIX qw(strftime tzset tzname);

use FindBin;
use lib ("$FindBin::RealBin/..", "$FindBin::RealBin/../lib");
use Strassen::Core;

use vars qw($temp_blockings_dir $temp_blockings_pl $temp_blockings_yml);

my $tz = "Europe/Berlin";
my $do_output_files;
my $check_net = 1;
my $v;
my $debug;
my $data_dir;
my $do_yaml = 0;
my $do_checks = 1;
my @action;
#my $temp_blockings_dir = "$FindBin::RealBin/../misc/temp_blockings";
if (!defined $temp_blockings_dir) {
    for my $test ("$FindBin::RealBin/data/temp_blockings",
		  "$FindBin::RealBin/../data/temp_blockings",
		 ) {
	if (-d $test) {
	    $temp_blockings_dir = $test;
	    last;
	}
    }
    warn "Can't find temp_blockings directory" if !$temp_blockings_dir;
}
$temp_blockings_pl  = "$temp_blockings_dir/bbbike-temp-blockings.pl"
    if !defined $temp_blockings_pl;
$temp_blockings_yml  = "$temp_blockings_dir/bbbike-temp-blockings.yml"
    if !defined $temp_blockings_yml;
my $file = $temp_blockings_pl;
my $yaml_file = $temp_blockings_yml;

my $longest_file_length;

my %german_month_to_num = qw(
    Januar 1
    Februar 2
    Mrz 3
    April 4
    Mai 5
    Juni 6
    Juli 7
    August 8
    September 9
    Oktober 10
    November 11
    Dezember 12
);
my $german_month_rx = '(?:' . join('|', map { quotemeta } keys %german_month_to_num) . ')';
$german_month_rx = qr{$german_month_rx};

my %german_ranges = (
    'Anfang' => [1,10],
    'Mitte'  => [10,20],
    'Ende'   => [20,31],
);
my $german_ranges_rx = '(?:' . join('|', map { quotemeta} keys %german_ranges) . ')';
$german_ranges_rx = qr{$german_ranges_rx};

sub process {
    local @ARGV = @_;

    if (!GetOptions("outputfiles" => \$do_output_files,
		    "f|file=s" => \$file,
		    "checknet!" => \$check_net,
		    "v|verbose+" => \$v,
		    "debug" => \$debug,
		    "useyaml!" => \$do_yaml,
		    'action=s@' => \@action,
		    "checks!" => \$do_checks,
		    "datadir=s" => \$data_dir,
		    "tz=s" => \$tz,
		   )) {
	die "usage";
    }

    if ($tz) {
	$ENV{TZ} = $tz;
	tzset;
    }

    if (!@action) {
	@action = "output_future_nonrecurring";
    }
    @action = grep { $_ ne 'none' } @action;
    for (@action) {
	if ($_ eq 'output_future_nonpermanent') {
	    warn "WARNING: rename 'output_future_nonpermanent' to 'output_future_nonrecurring'.\n";
	    $_ = 'output_future_nonrecurring';
	}
    }

    if (defined $v && $v >= 2) {
	Strassen::set_verbose($v - 1);
    }
}

# XXX use locks?
sub load_file {
    if ($do_yaml) {
	load_yaml_file();
    } else {
	load_perl_file();
    }
}

sub load_perl_file {
    if (!-r $file) {
	die "$file is not readable";
    }
    @temp_blocking = ();
    do $file;
    if (!@temp_blocking) {
	warn $@ if $@;
	system($^X, "-c", $file);
	die "No \@temp_blocking variable in $file found (perl check returned $?)";
    }
}

sub load_yaml_file {
    require BBBikeYAML;
    my $in = BBBikeYAML::LoadFile($yaml_file);
    @temp_blocking = @$in;
    if (!@temp_blocking) {
	die "No \@temp_blocking variable in $yaml_file found";
    }
}

sub run_checks {
    for my $o (@temp_blocking) {
	next if !$o; # undefined entry
	if (!exists $o->{from} || !exists $o->{until} ||
	    (!exists $o->{file} && !exists $o->{data}) ||
	    !exists $o->{text}) {
	    die "Incomplete definition: " . Dumper($o);
	}
	if ($o->{text} =~ m{^\s+$}) {
	    die "Empty text: " . Dumper($o);
	}
	if (exists $o->{type} && $o->{type} !~ /^(handicap|gesperrt)$/) {
	    die "Unknown type $o->{type}: " . Dumper($o);
	}
	if (defined $o->{from} && defined $o->{until} &&
	    $o->{from} > $o->{until}) {
	    die "Interval mismatch, from date is before until date: " . Dumper($o);
	}
	if (exists $o->{data}) {
	    if ($o->{data} =~ m{^\s*$}) {
		die "Empty data: " . Dumper($o);
	    }
	}

	my $str_obj;
	my $full_path;
	if ($o->{file}) {
	    $full_path = "$temp_blockings_dir/$o->{file}";
	    if (!-e $full_path) {
		die "ERROR: File $full_path is missing: " . Dumper($o);
	    }
	    if (!((stat($full_path))[2] & 0004)) {
		warn "WARNING: File $full_path is not readable for world\n";
	    }
	} elsif ($o->{data}) {
	    eval { 
		$str_obj = Strassen->new_from_data_string($o->{data});
		# Iterate over records for correctness check
		$str_obj->init;
		while(1) {
		    my $ret = $str_obj->next;
		    last if !@{$ret->[Strassen::COORDS]};
		}
	    };
	    if ($@) {
		die "ERROR: Corrupt data for " . Dumper($o) . ": $@\n";
	    }
	}

	next unless (!defined $o->{until} || $o->{until} > time);

	######################################################################
	# From here: checks only for future blockings
	
	# timestamp plausibility
	if (!$o->{dont_check_date} && $o->{text} =~ m{
							 (?:
							     (?<from_gerdayrange>$german_ranges_rx)\b\s*
							 |   (?<from_d>\d+)\.
							 )
							 (?:
							     \s*(?<from_germonth>$german_month_rx)\s*
							 |   (?<from_m>\d+)\.
							 )
							 (?<from_y>20\d+)
							 .*?
							 (?:
							     (?<until_gerdayrange>$german_ranges_rx)\b\s*
							 |   (?<until_d>\d+)\.
							 )
							 (?:
							     \s*(?<until_germonth>$german_month_rx)\s*
							 |   (?<until_m>\d+)\.
							 )
							 (?<until_y>20\d+)
						 }x) {
	    # pre/postwarn_days: handle possible mismatch between
	    # dates in text and dates in from/until fields
	    my $prewarn_days = defined $o->{prewarn_days} ? $o->{prewarn_days} : 1;
	    my $postwarn_days = defined $o->{postwarn_days} ? $o->{postwarn_days} : 1;
	    my $from_day_range  = defined $+{from_gerdayrange}  ? $german_ranges{$+{from_gerdayrange}}  : undef;
	    my $until_day_range = defined $+{until_gerdayrange} ? $german_ranges{$+{until_gerdayrange}} : undef;
	    my $from_m  = defined $+{from_germonth}  ? $german_month_to_num{$+{from_germonth}}  : $+{from_m};
	    my $until_m = defined $+{until_germonth} ? $german_month_to_num{$+{until_germonth}} : $+{until_m};

	    my($from_field, $from_and_one_day_field) = ('', '');
	    if (defined $o->{from}) {
		$from_field  = strftime "%F", localtime $o->{from};
		$from_and_one_day_field = strftime "%F", localtime $o->{from} + 86400 * $prewarn_days; # accept an additional day
	    }
	    my($until_field, $until_and_one_day_field) = ('', '');
	    if (defined $o->{until}) {
		$until_field = strftime "%F", localtime $o->{until};
		$until_and_one_day_field = strftime "%F", localtime $o->{until} - 86400 * $postwarn_days; # day before
	    }

	    my $die_text;
	    if (defined $from_day_range) {
		my $from_text_start = sprintf "%04d-%02d-%02d", $+{from_y},$from_m,$from_day_range->[0]; # XXX can't cope with prewarn days
		my $from_text_end   = sprintf "%04d-%02d-%02d", $+{from_y},$from_m,$from_day_range->[1];
		if ($from_field lt $from_text_start || $from_field gt $from_text_end) {
		    $die_text = "from date mismatch: $from_text_start..$from_text_end vs. $from_field in" . Dumper($o);
		}
	    } else {
		my $from_text  = sprintf "%04d-%02d-%02d", $+{from_y},$from_m,$+{from_d};
		if ($from_text ne $from_field && $from_text ne $from_and_one_day_field) {
		    $die_text = "from date mismatch: $from_text vs. $from_field and $from_and_one_day_field in " . Dumper($o);
		}
	    }
	    my $dont_check_end = $o->{text} =~ m{\b(?:evtl\.|eventuell|mglicherweise|vielleicht) (?:wird|werden) die (?:Sperrung|Baustelle|Bauarbeiten|Einbahnstraenregelung) verlngert};
	    if (!$dont_check_end) {
		if (defined $until_day_range) {
		    my $until_text_start = sprintf "%04d-%02d-%02d", $+{until_y},$until_m,$until_day_range->[0];
		    my $until_text_end   = sprintf "%04d-%02d-%02d", $+{until_y},$until_m,$until_day_range->[1]; # XXX can't cope with postwarn days
		    if ($until_field lt $until_text_start || $until_field gt $until_text_end) {
			$die_text = "until date mismatch: $until_text_start..$until_text_end vs. $until_field in" . Dumper($o);
		    }
		} else {
		    my $until_text = sprintf "%04d-%02d-%02d", $+{until_y},$until_m,$+{until_d};
		    if ($until_text ne $until_field && $until_text ne $until_and_one_day_field) {
			$die_text = "until date mismatch: $until_text vs. $until_field and $until_and_one_day_field in " . Dumper($o);
		    }
		}
	    }
	    if ($die_text) {
		my $suggestion_text;
		if ($tz) {
		    # Try to guess if tzset was successful
		    my($std,$dst) = tzname;
		    if ($dst =~ /^\s*$/) { # if TZ was not known in the tzset call -> Linux: empty string; FreeBSD: whitespace
			$suggestion_text = <<EOF;
It's possible that the timezone option (-tz) was ignored,
e.g. due to missing packages. On Debian or Ubuntu, try to
install the tzdata package:

    sudo apt-get install tzdata

EOF
		    }
		}
		if (!defined $suggestion_text) {
		    $suggestion_text = <<EOF;
Please set
       dont_check_date => 1,
or
       prewarn_days => ..., postwarn_days => ...,
to ignore this failure.

EOF
		}
		die $die_text . "SUGGESTION:\n" . $suggestion_text;
	    }
	}

	if ($check_net) {
	    my $name = _get_name($o);
	    warn "Check $name...\n" if $v;

	    $longest_file_length = length $name
		if !defined $longest_file_length || length $name > $longest_file_length;

	    if ($o->{data} && $str_obj) {
		require File::Temp;
		(my($fh), $full_path) = File::Temp::tempfile(SUFFIX => "_cbtb.bbd",
							     UNLINK => 1);
		$str_obj->write($full_path);
	    }

	    # Checks for now restricted to Berlin
	    warn "  Check points...\n" if $v;
	    require "$FindBin::RealBin/check_points";
	    my $ret = BBBike::check_points::doit
		("-q", ($debug ? "-debug" : ()), "-memcache", $full_path, "strassen", "faehren");
	    if ($ret != 0) {
		# Otherwise do a full region check
		warn "  Check points (wide region)...\n" if $v;
		$ret = BBBike::check_points::doit
		    (($debug ? "-debug" : ()), "-report", "-memcache", $full_path,
		     "strassen", "faehren", "landstrassen", "landstrassen2");
		if ($ret != 0) {
		    die "File $full_path (containing " . Dumper($o) . " failed check_points test";
		}
	    }

	    my $datadirprefix = $data_dir ? "$data_dir/" : "";
	    my @opt = $v ? ('-v') : ();
	    warn "  Check neighbors...\n" if $v;
	    require "$FindBin::RealBin/check_neighbour";
	    if (!eval {
		BBBike::check_neighbour::doit
			("-type", "standard", "-data", $full_path,
			 "-against", $datadirprefix."strassen",
			 "-against", $datadirprefix."faehren",
			 "-keepnet", "-q", @opt);
		1;
	    } && !eval {
		warn "  Check neighbors (wide region)...\n" if $v;
		BBBike::check_neighbour::doit
			("-type", "standard", "-data", $full_path,
			 "-against", $datadirprefix."strassen",
			 "-against", $datadirprefix."faehren",
			 "-against", $datadirprefix."landstrassen",
			 "-against", $datadirprefix."landstrassen2",
			 "-keepnet", @opt);
		1;
	    }) {
		die "File $full_path failed check_neighbour test";
	    }
	}
    }
}

sub output_future_nonrecurring {
    _output_future(includerecurring => 0);
}

sub output_future {
    _output_future(includerecurring => 1);
}

sub _output_future {
    my(%args) = @_;
    my $include_recurring = delete $args{includerecurring};
    die "Unhandled args: " . join(' ', %args) if %args;

    use constant LENGTH_OF_DATE_STRINGS => 55;
    use constant LENGTH_OF_ID => 4;
    # Sortieren nach dem nchsten Ereignis (Beginn oder Ende)
    no warnings 'uninitialized';
    my $id = 0;
    my @errors;
    for my $o (map  { $_->[1] }
	       sort { $a->[0] <=> $b->[0] }
	       map  {
		   my $cmp_time;
		   if ($_->{from} >= time) {
		       $cmp_time = $_->{from};
		   } elsif ($_->{until} >= time) {
		       $cmp_time = $_->{until};
		   } else {
		       $cmp_time = $_->{from};
		   }
		   [$cmp_time, $_];
	       }
	       grep { $_ }
	       map {
		   if ($_) {
		       $_->{id} = $id;
		   }
		   $id++;
		   $_;
	       } @temp_blocking) {
	if (!defined $o->{until} || $o->{until} > time) {
	    next if !$include_recurring && ($o->{permanent} || $o->{recurring});
	    if ($do_output_files) {
		print _get_name($o), "\n";
	    } else {
		my $id = $o->{id};
		if ($v) {
		    my $name = _get_name($o);
		    my $max_name_len = 80 - LENGTH_OF_DATE_STRINGS - LENGTH_OF_ID - 2;
		    if ($longest_file_length > $max_name_len) {
			$longest_file_length = $max_name_len;
		    }
		    $name = substr($name, 0, $max_name_len)
			if length $name > $max_name_len;
		    printf STDERR " %".LENGTH_OF_ID."d %-${longest_file_length}s: %s - %s\n",
			$id,
			    $name, format_date($o->{from}),
				format_date($o->{until});
		}
		if ($o->{file}) {
		    my $msg = "Found 'file' entry in record id $id.";
		    our $file_entry_diagnostics;
		    if (!$file_entry_diagnostics++) {
			$msg .= <<EOF;

'file' entries are not allowed anymore in
"optimized" files, because it's possibly downloaded
during bbbike data updates
EOF
		    }
		    push @errors, $msg;
		}
	    }
	}
    }
    if (@errors) {
	die "Found the following errors:\n" . join("\n", @errors);
    }
}

sub return_future {
    my @res;
    for my $i (0 .. $#temp_blocking) {
	if ($temp_blocking[$i]) {
	    $temp_blocking[$i]->{"index"} = $i;
	}
    }
    no warnings 'uninitialized'; # from may be undef
    for my $o (sort { $a->{from} <=> $b->{from} } grep { $_ } @temp_blocking) {
	if (!defined $o->{until} || $o->{until} > time) {
	    push @res, $o;
	}
    }
    @res;
}

sub dump_future_as_perl {
    my @new_temp_blocking;
    my $first_index;
    for my $i (0 .. $#temp_blocking) {
	my $o = $temp_blocking[$i];
	if (defined $o) {
	    if (!defined $o->{until} || $o->{until} > time) {
		if (!defined $first_index) {
		    $first_index = $i;
		}
		$new_temp_blocking[$i] = $temp_blocking[$i];
	    }
	}
    }
    if (!$first_index) {
	warn "NOTE: No active or future records found.\n";
    }
    my $s = <<EOF;
\@temp_blocking = ();
EOF
    if ($first_index > 1) {
	$s = <<EOF;
\$#temp_blocking = @{[ $first_index-1 ]};
push \@temp_blocking,
EOF
    } else {
	$s = <<'EOF';
@temp_blocking =
EOF
    }
    my $dd = Data::Dumper->new([[@new_temp_blocking[$first_index .. $#new_temp_blocking]]], ["x"])->Sortkeys(1)->Dump;
    $dd =~ s/\A\$x\s*=\s*\[//;
    $dd =~ s/\];\Z//;
    $s .= "(";
    $s .= $dd;
    $s .= ");\n";

    if (0) { # Testing only
	my $temp = "/tmp/n";
	open(OUT, "> $temp") or die $!;
	print OUT $s;
	close OUT;

	my $old = `$^X $0 -action output_future 2>&1`;
	my $new = `$^X $0 -action output_future -f $temp 2>&1`;
	unlink $temp;

	die "$old\n====================\n$new\n"
	    if $old ne $new;
    }

    print $s;
}

sub format_date {
    my $time = shift;
    return sprintf "%-24s", "..." if (!defined $time);
    my @l = localtime $time;
    strftime "%d.%m.%Y %H:%M:%S (%a)", @l;
}

sub _get_name {
    my $o = shift;
    if ($o->{file}) {
	$o->{file};
    } elsif ($o->{text}) {
	my $name = substr($o->{text}, 0, 25);
	$name =~ s/(?<=\s)\S+$//;
	$name =~ s/[\.,;\s]+$//;
	$name;
    } else {
	"Data for " . ($o->{from}||"...") ." - " . ($o->{until}||"...");
    }
}

return 1 if caller;

process(@ARGV);
load_file();
run_checks() if $do_checks;
for my $action (@action) {
    no strict 'refs';
    $action->();
}

__END__

=head1 DESCRIPTION

Allowed actions:

 - output_future (default, if nothing is given)
 - none: do nothing
 - ... more?
