File Coverage

blib/lib/YATT/Lite/Test/XHFTest2.pm

Criterion	Covered	Total	%
statement	53	233	22.7
branch	0	74	0.0
condition	0	39	0.0
subroutine	18	49	36.7
pod	0	29	0.0
total	71	424	16.7

package YATT::Lite::Test::XHFTest2; sub Tests () {__PACKAGE__}
use strict;
use warnings qw(FATAL all NONFATAL misc);
use Exporter qw(import);

use File::Basename qw(dirname);

use base qw(YATT::Lite::Object);
use fields qw/files cf_dir cf_libdir
	      cf_debug
	      cookie_jar/;
use YATT::Lite::Types
  (export_default => 1
   , [File => -fields => [qw(cf_file items
			     cf_REQUIRE cf_USE_COOKIE
			     cf_FILE_READABLE
			   )]]
   , [Item => -fields => [qw(cf_TITLE cf_FILE cf_METHOD cf_ACTION
			     cf_BREAK
			     cf_SKIP_IF_ERROR
			     cf_SAME_RESULT
			     cf_PERL_MINVER
			     cf_SITE_CONFIG
			     cf_PARAM cf_HEADER cf_BODY cf_ERROR)]]);

our @EXPORT;
push @EXPORT, qw(trimlast nocr);

use Carp;
use Test::More;
use YATT::Lite::Test::TestUtil;
use File::Basename;
use List::Util qw(sum);

use YATT::Lite::Util qw(lexpand untaint_any rootname);

push @EXPORT, qw(plan is is_deeply like eq_or_diff sum);

sub load_tests {
  my ($pack, $spec) = splice @_, 0, 2;
  my Tests $tests = $pack->new(@$spec);
  foreach my $fn ($tests->list_xhf(@_)) {
    push @{$tests->{files}}, $tests->load_file($fn);
  }
  $tests;
}

sub enter {
  (my Tests $tests) = @_;
  unless (defined $tests->{cf_dir}) {
    croak "dir is undef";
  }
  chdir $tests->{cf_dir} or die "Can't chdir to '$tests->{cf_dir}': $!";
}

sub test_plan {
  my Tests $self = shift;
  unless ($self->{files} and @{$self->{files}}) {
    return skip_all => "No t/*.xhf are defined";
  }
  foreach my File $file (@{$self->{files}}) {
    foreach my $fn (lexpand $file->{cf_FILE_READABLE}) {
      # Note: This assumes $tests->test_plan is called after $tests->enter.
      unless (-r $fn) {
	return skip_all => "FILE $fn is not readable"
      }
    }
    foreach my $req (lexpand($file->{cf_REQUIRE})) {
      unless (eval qq{require $req}) {
	return skip_all => "$req is not installed.";
      }
    }
  }
  (tests => $self->ntests(@_));
}

sub load_dispatcher {
  my Tests $self = shift;
  require YATT::Lite::Factory;
  my $script = do {
    if (defined $self->{cf_libdir}) {
      my $rn = rootname($self->{cf_libdir});
      my @found = grep {-r} map {"$rn.$_"} qw(cgi psgi);
      $found[0];
    } elsif (-r (my $psgi = dirname($self->{cf_dir}) . "/app.psgi")) {
      $psgi;
    } else {
      undef;
    }
  };
  unless ($script and -r $script) {
    croak "Can't load dispatcher. runyatt.cgi, runyatt.psgi or app.psgi is required";
  }

  # $dir/t/../app.psgi => $dir/app.psgi
  (my $realpath = $script) =~ s{/([^\.][^/]*)/\.\.(?:/|$)}{/}g;

  my $dispatcher = YATT::Lite::Factory->load_factory_script($realpath);
  $dispatcher->configure(noheader => 1);
  $dispatcher;
}

sub ntests {
  my Tests $tests = shift;
  sum(@_, map {$tests->ntests_per_file($_)} @{$tests->{files}});
}

sub ntests_per_file {
  (my Tests $tests, my File $file) = @_;
  sum(map {$tests->ntests_per_item($_)} @{$file->{items}});
}

sub ntests_per_item {
  (my Tests $tests, my Item $item) = @_;
  $item->{cf_ACTION} ? 0 : 1;
}

sub file_title {
  (my Tests $tests, my File $file) = @_;
  join ';', $tests->{cf_dir}, basename($file->{cf_file});
}

sub mkpat_by {
  (my Tests $tests, my $sep) = splice @_, 0, 2;
  my $str = join $sep, map {ref $_ ? @$_ : $_} @_;
  qr{$str}sm;
}

sub mkpat { shift->mkpat_by('|', @_) }
sub mkseqpat { shift->mkpat_by('.*?', @_) }

sub list_xhf {
  my $pack = shift;
  unless (@_) {
    <*.xhf>
  } else {
    map {
      -d $_ ? <$_/*.xhf> : $_
    } @_;
  }
}

use YATT::Lite::XHF;
sub Parser {'YATT::Lite::XHF'}
# XXX: Currently, all t/*.xhf is loaded as binary (not Wide char).
sub load_file {
  shift->load_file_into([], @_);
}

sub load_file_into {
  my ($pack, $array, $fn) = splice @_, 0, 3;
  _with_loading_file {$pack} $fn, sub {
    my File $file = $pack->File->new(file => $fn);
    my $parser = $pack->Parser->new(file => $fn);
    if (my @global = $parser->read(skip_comment => 0)) {
      $file->configure(@global);
    }
    while (my @config = $parser->read) {
      if (@config == 2 and $config[0] =~ /^include$/i) {
	$pack->load_file_into($file->{items} //= [], $pack->resolve_in($fn, $_))
	  for lexpand $config[1];
      } else {
	push @{$file->{items}}, $pack->Item->new(@config);
      }
    }
    push @$array, @{$file->{items}};
    $file;
  };
}

sub resolve_in {
  my ($pack, $origfn, $newfn) = @_;
  dirname($origfn) . '/' . $newfn;
}

#========================================
use 5.010; no if $] >= 5.017011, warnings => "experimental";

sub mechanized {
  (my Tests $tests, my $mech) = @_;
  foreach my File $sect (@{$tests->{files}}) {
    my $dir = $tests->{cf_dir};
    my $sect_name = $tests->file_title($sect);

    my $last_body;
    foreach my Item $item (@{$sect->{items}}) {

      if (my $action = $item->{cf_ACTION}) {
	my ($method, @args) = @$action;
	my $sub = $tests->can("action_$method")
	  or die "No such action: $method";
	$sub->($tests, @args);
	next;
      }

      my $method = $tests->item_method($item);
      my $error;
      local $mech->{onerror} = sub {
	$error = join " ", @_;
      };
      my $res = $tests->mech_request($mech, $item);
      my $T = defined $item->{cf_TITLE} ? "[$item->{cf_TITLE}]" : '';

      SKIP: {
	if (defined $error) {
	  if (defined $item->{cf_SKIP_IF_ERROR}
	      and $error =~ m{$item->{cf_SKIP_IF_ERROR}}) {
	    my $skip_count = $tests->skipcount_for_request_error($item);
	    skip $error, $skip_count;
	  } else {
	    fail "[$sect_name] $T Unknown error: $error";
	    next;
	  }
	}

	if ($item->{cf_HEADER} and my @header = @{$item->{cf_HEADER}}) {
	  while (my ($key, $pat) = splice @header, 0, 2) {
	    my $title = "[$sect_name] $T HEADER $key of $method $item->{cf_FILE}";
	    if ($res) {
	      like $res->header($key), qr{$pat}s, $title;
	    } else {
	      fail "$title - no \$res";
	    }
	  }
	}

	if (my $body = $item->{cf_SAME_RESULT} ? $last_body : $item->{cf_BODY}) {
	  if (ref $body) {
	    like nocr($mech->content), $tests->mkseqpat($body)
	      , "[$sect_name] $T BODY of $method $item->{cf_FILE}";
	  } else {
	    eq_or_diff trimlast(nocr($mech->content)), $body
	      , "[$sect_name] $T BODY of $method $item->{cf_FILE}";
	  }
	} elsif (my $errpat = $item->{cf_ERROR}) {
	  $errpat =~ s{\^}{^(?:(?i)ERROR: )?};

	  # XXX: It might be better to wrap $mech to have specialized ->title()
	  # for http_localhost.t too.
	  #
	  like $mech->title // $mech->content, qr{$errpat}
	    , "[$sect_name] $T ERROR of $method $item->{cf_FILE}";
	}
      }
    } continue {
      $last_body = $item->{cf_BODY} if $item->{cf_BODY};
    }
  }
}

sub item_method {
  (my Tests $tests, my ($item)) = @_;
  $item->{cf_METHOD} // 'GET';
}

sub run_psgicb {
  (my Tests $tests, my ($cb, $item)) = @_;
  my $jar = $tests->{cookie_jar} ||= do {
    require HTTP::Cookies;
    HTTP::Cookies->new;
  };
  my $req = $tests->mkrequest($item);
  my $res = $cb->($req);
  $jar->extract_cookies($res);
  $res;
}

sub mkrequest {
  (my Tests $tests, my Item $item) = @_;
  require HTTP::Request::Common;
  my $builder = HTTP::Request::Common->can($item->{cf_METHOD});
  my $req = $builder->($tests->item_url($item)
		       , $tests->mkformref_if_post($item));
  if (my $jar = $tests->{cookie_jar}) {
    $jar->add_cookie_header($req);
  }
  $req;
}

sub mkformref_if_post {
  (my Tests $tests, my Item $item) = @_;
  return unless $item->{cf_METHOD} eq 'POST';
  defined (my $ary = $item->{cf_PARAM})
    or return;
  if (ref $ary eq 'ARRAY'
      and grep(ref $_ eq 'HASH', @$ary)
      or ref $ary eq 'HASH'
      and grep(ref $_ eq 'HASH', values %$ary)) {
    croak "HASH value is not allowed in PARAM block!";
  }
  $ary;
}

sub mech_request {
  (my Tests $tests, my ($mech, $item)) = @_;
  my $url = $tests->item_url($item);
  given ($tests->item_method($item)) {
    when ('GET') {
      return $mech->get($url);
    }
    when ('POST') {
      return $mech->post($url, $item->{cf_PARAM});
    }
    default {
      die "Unknown test method: $_\n";
    }
  }
}

sub item_url {
  (my Tests $tests, my Item $item) = @_;
  my $url = do {
    if (($item->{cf_METHOD} // '') eq 'POST') {
      $tests->item_url_file($item)
    } else {
      join '?', $tests->item_url_file($item), $tests->item_query($item);
    }
  };
  print STDERR "#item_url: $url\n" if $tests->{cf_debug};
  $url;
}

sub item_url_file {
  (my Tests $tests, my Item $item) = @_;
  $tests->base_url . $item->{cf_FILE}
}

use YATT::Lite::Util qw(encode_query);
sub item_query {
  (my Tests $tests, my Item $item) = @_;
  my $param = $item->{cf_PARAM}
    or return;
  $tests->encode_query($item->{cf_PARAM});
}

sub skipcount_for_request_error {
  (my Tests $tests, my Item $item) = @_;
  lexpand($item->{cf_HEADER})/2
    + (defined $item->{cf_BODY} || defined $item->{cf_ERROR});
}

#========================================
sub action_remove {
  my Tests $tests = shift;
  my @files = glob(shift);
  unlink map {untaint_any($_)} @files if @files;
}

#========================================
sub trimlast {
  return undef unless defined $_[0];
  $_[0] =~ s/\s+$/\n/g;
  $_[0];
}

use Encode qw(is_utf8 encode);
sub nocr {
  return undef unless defined $_[0];
  $_[0] =~ s|\r||g;
  if (is_utf8($_[0])) {
    encode(utf8 => $_[0]);
  } else {
    $_[0];
  }
}

1;