#!/usr/bin/env perl
#----------------------------------------
use strict;
use warnings FATAL => qw(all);
use FindBin; my $libdir; BEGIN {($libdir) = do "$FindBin::RealBin/libdir.pl"}
#----------------------------------------
use 5.010;
use Cwd qw(realpath);

use Test::More;
use Test::Differences;
use List::Util qw(sum);

use YATT::Lite::Breakpoint;
use YATT::Lite::XHF;
use YATT::Lite::Util qw(ostream);

{
  package TestSection;
  use base qw(YATT::Lite::Object);
  use fields qw(cf_file items);
  sub ntests {
    my TestSection $self = shift;
    scalar @{$self->{items}};
  }

  package TestItem;
  use base qw(YATT::Lite::Object);
  use fields qw(cf_TITLE cf_FILE cf_METHOD
		cf_PARAM
		cf_HEADER cf_BODY);
}

use Getopt::Long;
GetOptions("m|mode=s", \ my $mode)
  or die "Usage: [--mode=...] [t/*.xhf]";

my @section = map {
  my TestSection $section = new TestSection(file => $_);
  my $parser = new YATT::Lite::XHF(file => $_);
  if (my @global = $parser->read) {
    $section->configure(@global);
  }
  while (my @config = $parser->read) {
    push @{$section->{items}}, new TestItem(@config);
  }
  # XXX: . とか渡したときに、全然ダメじゃん。
  $section;
} @ARGV ? @ARGV : <t/*.xhf>;
# XXX: dict_sort

unless (@section) {
  plan skip_all => "No testfile (t/*.xhf) found";
  exit;
}

my $sub = MY->can(join '', mode_ => ($mode // "http_localhost"))
  or die "No such test mode: $mode\n";
$sub->(MY, @section);

sub mode_http_localhost {
  my ($pack, @section) = @_;
  plan tests => sum(map {$_->ntests} @section);
  require WWW::Mechanize;
  my $mech = new WWW::Mechanize;
  foreach my TestSection $sect (@section) {
    # 正しく設定されていれば、 .htaccess の x-yatt-handler 行には url が書かれている。
    # ここから base_url を取り出す。
    my $dir = dirname(realpath($sect->{cf_file}));
    $dir =~ s{/t$}{}; # $sect->{cf_file} is assumed t/*.xhf
    my $sect_name = basename($dir).';'.basename($sect->{cf_file});
    my $cgi_url = $pack->find_yatt_handler
      (realpath(dirname($sect->{cf_file}) . "/../.htaccess"));
    (my $base_url = $cgi_url) =~ s|/cgi-bin/\w+\.f?cgi$|/|;

    foreach my TestItem $item (@{$sect->{items}}) {
      my $url = join '', 'http://localhost', $base_url, $item->{cf_FILE};
      $item->{cf_METHOD} //= 'GET';
      given ($item->{cf_METHOD}) {
	when ('GET') {
	  my $res = $mech->get($url);
	  eq_or_diff trimlast(nocr($mech->content)), $item->{cf_BODY}
	    , "[$sect_name] $_ $item->{cf_FILE}";
	}
	when ('POST') {
	  my $res = $mech->post($url, $item->{cf_PARAM});
	  my $pat = join("|", @{$item->{cf_HEADER}});
	  like $res->previous->as_string, qr{$pat}sm
	    , "[$sect_name] $_ $item->{cf_FILE}";
	}
	default {
	  die "Unknown test method: $_\n";
	}
      }
    }
  }
}

sub mode_internal {
  my ($pack, @section) = @_;
  plan tests => sum(map {$_->ntests} @section);

  # do で runyatt.cgi を load し、 $dispatcher を取り出す！
  (my $cgi = $libdir) =~ s/\.\w+$/.cgi/;
  my $dispatcher = YATT::Lite::Factory->load_factory_offline || do {
    require YATT::Lite::WebMVC0::SiteApp;
    YATT::Lite::WebMVC0::SiteApp->new
	(app_ns => 'MyApp'
	 , namespace => ['yatt', 'perl', 'js']
	 , header_charset => 'utf-8'
	 , debug_cgen => $ENV{DEBUG}
	 , debug_cgi  => $ENV{DEBUG_CGI}
	 # , is_gateway => $ENV{GATEWAY_INTERFACE} # Too early for FastCGI.
	 # , tmpl_encoding => 'utf-8'
	);
  };

  foreach my TestSection $sect (@section) {
    my $dir = dirname(realpath($sect->{cf_file}));
    $dir =~ s{/t$}{}; # $sect->{cf_file} is assumed t/*.xhf
    my $sect_name = basename($dir).';'.basename($sect->{cf_file});
    foreach my TestItem $item (@{$sect->{items}}) {
      $dispatcher->run_dirhandler
	(ostream(my $buffer)
	 , $dispatcher->make_cgi("$dir/$item->{cf_FILE}", $item->{cf_PARAM}));
      eq_or_diff trimlast(nocr($buffer)), $item->{cf_BODY}
	, "[$sect_name] GET $item->{cf_FILE}";
    }
  }
}

sub find_yatt_handler {
  my $pack = shift;
  local $_;
  foreach my $fn (@_) {
    open my $fh, '<', $fn or do { warn "$fn: $!"; next };
    while (<$fh>) {
      next unless m/^Action\s+x-yatt-handler\s+(\S+)/;
      return $1;
    }
  }
  die "Can't find x-yatt-handler in any of: @_";
}

sub trimlast {
  $_[0] =~ s/\s+$/\n/g;
  $_[0];
}

sub nocr {
  $_[0] =~ s|\r||g;
  $_[0];
}