Commit | Line | Data |
6dac2638 |
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 |
c98f0498 |
11 | MECH |
6dac2638 |
12 | /; |
13 | |
14 | use constant (); |
15 | BEGIN { |
16 | my $mech = eval { |
17 | require Test::WWW::Mechanize::Catalyst; |
c98f0498 |
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; |
6dac2638 |
24 | }; |
25 | constant->import('MECH', $mech ); |
26 | } |
27 | |
cd196b66 |
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 | |
6dac2638 |
50 | sub test_uri { |
51 | my ($uri, $qs) = @_; |
6dac2638 |
52 | my $request = "/$uri"; |
53 | $request .= "?$qs" if defined $qs; |
54 | my $response = request($request); |
cd196b66 |
55 | ok($response->is_success, "ok $request"); |
6dac2638 |
56 | if (MECH) { |
57 | my $res = MECH()->get($request); |
cd196b66 |
58 | ok $res->is_success, "ok mech $request (" . $res->code . ')'; |
59 | MECH()->page_links_ok("All links ok from $request") |
6dac2638 |
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; |