t/lib/TestGitalist.pm

   1 package TestGitalist;
   2 use strict;
   3 use warnings;
   4 use Exporter qw/import/;
   5 use Catalyst::Test qw/Gitalist/;
   6 use Test::More;
   7
   8 our @EXPORT = qw/
   9     test_uri
  10     curry_test_uri
  11     MECH
  12 /;
  13
  14 use constant ();
  15 BEGIN {
  16     my $mech = eval {
  17         require Test::WWW::Mechanize::Catalyst;
  18         require WWW::Mechanize::TreeBuilder;
  19         my $mech = Test::WWW::Mechanize::Catalyst->new(catalyst_app => 'Gitalist');
  20         WWW::Mechanize::TreeBuilder->meta->apply($mech, {
  21            tree_class => 'HTML::TreeBuilder::XPath',
  22         } );
  23         return $mech;
  24     };
  25     constant->import('MECH', $mech );
  26 }
  27
  28 # Rechecking the same link multiple times is slow and lame!
  29 # Nicked this from WWW::Mechanize and memoized it...
  30 my %seen_links;
  31 sub Test::WWW::Mechanize::Catalyst::page_links_ok {
  32     my $self = shift;
  33     my $desc = shift;
  34
  35     $desc = 'All links ok' unless defined $desc;
  36
  37     my @links = $self->followable_links();
  38     my @urls = Test::WWW::Mechanize::_format_links(\@links);
  39
  40     my @failures = $self->_check_links_status( [ grep { ! $seen_links{$_}++ } @urls ] );
  41     my $ok = (@failures==0);
  42
  43     ok( $ok, $desc );
  44     diag( $_ ) for @failures;
  45
  46     return $ok;
  47 }
  48
  49
  50 sub test_uri {
  51     my ($uri, $qs) = @_;
  52     my $request = "/$uri";
  53     $request .= "?$qs" if defined $qs;
  54     my $response = request($request);
  55     ok($response->is_success, "ok $request");
  56     if (MECH) {
  57         my $res = MECH()->get($request);
  58         ok $res->is_success, "ok mech $request (" . $res->code . ')';
  59         MECH()->page_links_ok("All links ok from $request")
  60             if $res->content_type =~ m|text/html|;
  61     }
  62     return $response;
  63 }
  64
  65 sub curry_test_uri {
  66     my $prefix = shift;
  67     my $to_curry = shift || \&test_uri;
  68     sub {
  69         my $uri = shift;
  70         $to_curry->("$prefix/$uri", @_);
  71     };
  72 }
  73
  74 1;