Commit | Line | Data |
c7ded7aa |
1 | #!perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
ec6213a0 |
6 | use Test::More; |
d258fcb2 |
7 | use FindBin qw/$Bin/; |
b1ead5a2 |
8 | use lib "$Bin/../lib"; |
d9d04ded |
9 | use Catalyst::Utils; |
4348c28b |
10 | use HTTP::Request::Common; |
6f8be318 |
11 | use Test::Exception; |
c7ded7aa |
12 | |
26dd6d9f |
13 | my $Class = 'Catalyst::Test'; |
14 | my $App = 'TestApp'; |
15 | my $Pkg = __PACKAGE__; |
16 | my $Url = 'http://localhost/'; |
17 | my $Content = "root index"; |
c7ded7aa |
18 | |
26dd6d9f |
19 | my %Meth = ( |
4fbc0e85 |
20 | $Pkg => [qw|get request ctx_request|], # exported |
26dd6d9f |
21 | $Class => [qw|local_request remote_request|], # not exported |
22 | ); |
c7ded7aa |
23 | |
26dd6d9f |
24 | ### make sure we're not trying to connect to a remote host -- these are local tests |
702729f5 |
25 | local $ENV{CATALYST_SERVER}; |
c7ded7aa |
26 | |
ec6213a0 |
27 | use Catalyst::Test (); |
26dd6d9f |
28 | |
29 | ### check available methods |
30 | { ### turn of redefine warnings, we'll get new subs exported |
31 | ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in |
32 | ### test.pm, so trap them for now --kane |
33 | { local $SIG{__WARN__} = sub {}; |
34 | ok( $Class->import, "Argumentless import for methods only" ); |
35 | } |
36 | |
37 | while( my($class, $meths) = each %Meth ) { |
38 | for my $meth ( @$meths ) { SKIP: { |
702729f5 |
39 | |
26dd6d9f |
40 | ### method available? |
41 | can_ok( $class, $meth ); |
42 | |
43 | ### only for exported methods |
44 | skip "Error tests only for exported methods", 2 unless $class eq $Pkg; |
45 | |
46 | ### check error conditions |
47 | eval { $class->can($meth)->( $Url ) }; |
48 | ok( $@, " $meth without app gives error" ); |
702729f5 |
49 | like( $@, qr/$Class/, |
26dd6d9f |
50 | " Error filled with expected content for '$meth'" ); |
702729f5 |
51 | } } |
26dd6d9f |
52 | } |
702729f5 |
53 | } |
54 | |
55 | ### simple tests for exported methods |
26dd6d9f |
56 | { ### turn of redefine warnings, we'll get new subs exported |
57 | ### XXX 'no warnings' and 'local $^W' wont work as warnings are turned on in |
58 | ### test.pm, so trap them for now --kane |
59 | { local $SIG{__WARN__} = sub {}; |
702729f5 |
60 | ok( $Class->import( $App ), |
26dd6d9f |
61 | "Loading $Class for App $App" ); |
62 | } |
702729f5 |
63 | |
26dd6d9f |
64 | ### test exported methods again |
65 | for my $meth ( @{ $Meth{$Pkg} } ) { SKIP: { |
66 | |
f2e13bbd |
67 | ### do a call, we should get a result and perhaps a $c if it's 'ctx_request'; |
26dd6d9f |
68 | my ($res, $c) = eval { $Pkg->can($meth)->( $Url ) }; |
702729f5 |
69 | |
26dd6d9f |
70 | ok( 1, " Called $Pkg->$meth( $Url )" ); |
71 | ok( !$@, " No critical error $@" ); |
72 | ok( $res, " Result obtained" ); |
702729f5 |
73 | |
26dd6d9f |
74 | ### get the content as a string, to make sure we got what we expected |
75 | my $res_as_string = $meth eq 'get' ? $res : $res->content; |
76 | is( $res_as_string, $Content, |
702729f5 |
77 | " Content as expected: $res_as_string" ); |
78 | |
f2e13bbd |
79 | ### some tests for 'ctx_request' |
80 | skip "Context tests skipped for '$meth'", 6 unless $meth eq 'ctx_request'; |
702729f5 |
81 | |
26dd6d9f |
82 | ok( $c, " Context object returned" ); |
83 | isa_ok( $c, $App, " Object" ); |
84 | is( $c->request->uri, $Url, |
85 | " Url recorded in request" ); |
86 | is( $c->response->body, $Content, |
87 | " Content recorded in response" ); |
88 | ok( $c->stash, " Stash accessible" ); |
89 | ok( $c->action, " Action object accessible" ); |
12755afc |
90 | ok( $res->request, " Response has request object" ); |
91 | lives_and { is( $res->request->uri, $Url) } |
92 | " Request object has correct url"; |
26dd6d9f |
93 | } } |
94 | } |
d9d04ded |
95 | |
702729f5 |
96 | ### perl5.8.8 + cat 5.80's Cat::Test->ctx_request didn't return $c the 2nd |
ba151d0d |
97 | ### time it was invoked. Without tracking the bug down all the way, it was |
98 | ### clearly related to the Moose'ification of Cat::Test and a scoping issue |
99 | ### with a 'my'd variable. Since the same code works fine in 5.10, a bug in |
100 | ### either Moose or perl 5.8 is suspected. |
101 | { ok( 1, "Testing consistency of ctx_request()" ); |
102 | for( 1..2 ) { |
103 | my($res, $c) = ctx_request( $Url ); |
104 | ok( $c, " Call $_: Context object returned" ); |
105 | } |
702729f5 |
106 | } |
ba151d0d |
107 | |
4348c28b |
108 | # FIXME - These vhosts in tests tests should be somewhere else... |
109 | |
759d380e |
110 | sub customize { Catalyst::Test::_customize_request($_[0], {}, @_[1 .. $#_]) } |
d9d04ded |
111 | |
112 | { |
113 | my $req = Catalyst::Utils::request('/dummy'); |
114 | customize( $req ); |
115 | is( $req->header('Host'), undef, 'normal request is unmodified' ); |
116 | } |
117 | |
118 | { |
119 | my $req = Catalyst::Utils::request('/dummy'); |
120 | customize( $req, { host => 'customized.com' } ); |
121 | like( $req->header('Host'), qr/customized.com/, 'request is customizable via opts hash' ); |
122 | } |
123 | |
124 | { |
125 | my $req = Catalyst::Utils::request('/dummy'); |
126 | local $Catalyst::Test::default_host = 'localized.com'; |
127 | customize( $req ); |
128 | like( $req->header('Host'), qr/localized.com/, 'request is customizable via package var' ); |
129 | } |
130 | |
131 | { |
132 | my $req = Catalyst::Utils::request('/dummy'); |
133 | local $Catalyst::Test::default_host = 'localized.com'; |
134 | customize( $req, { host => 'customized.com' } ); |
135 | like( $req->header('Host'), qr/customized.com/, 'opts hash takes precedence over package var' ); |
136 | } |
137 | |
138 | { |
139 | my $req = Catalyst::Utils::request('/dummy'); |
140 | local $Catalyst::Test::default_host = 'localized.com'; |
141 | customize( $req, { host => '' } ); |
142 | is( $req->header('Host'), undef, 'default value can be temporarily cleared via opts hash' ); |
143 | } |
d258fcb2 |
144 | |
145 | # Back compat test, extra args used to be ignored, now a hashref of options. |
146 | use_ok('Catalyst::Test', 'TestApp', 'foobar'); |
4348c28b |
147 | |
148 | # Back compat test, ensure that request ignores anything which isn't a hash. |
149 | lives_ok { |
150 | request(GET('/dummy'), 'foo'); |
151 | } 'scalar additional param to request method ignored'; |
152 | lives_ok { |
153 | request(GET('/dummy'), []); |
154 | } 'array additional param to request method ignored'; |
269194b4 |
155 | |
89222c2a |
156 | my $res = request(GET('/')); |
157 | is $res->code, 200, 'Response code 200'; |
158 | is $res->headers->{status}, 200, 'Back compat "status" header present'; |
159 | |
ec6213a0 |
160 | done_testing; |