This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CGI to CPAN version 3.55
[perl5.git] / cpan / CGI / t / url.t
1 use strict;
2 use warnings;
3
4 use Test::More;
5
6 use CGI ':all';
7
8
9 $ENV{HTTP_X_FORWARDED_HOST} = 'proxy:8484';
10 $ENV{SERVER_PROTOCOL}       = 'HTTP/1.0';
11 $ENV{SERVER_PORT}           = 8080;
12 $ENV{SERVER_NAME}           = 'the.good.ship.lollypop.com';
13
14 is virtual_port() => 8484, 'virtual_port()';
15 is server_port()  => 8080, 'server_port()';
16
17 is url() => 'http://proxy:8484', 'url()';
18
19 # let's see if we do the defaults right
20
21 $ENV{HTTP_X_FORWARDED_HOST} = 'proxy:80';
22
23 is url() => 'http://proxy', 'url() with default port';
24
25 subtest 'rewrite_interactions' => sub {
26     # Reference: RT#45019
27
28     local %ENV =  (
29       # These two are always set
30       'SCRIPT_NAME'     => '/real/cgi-bin/dispatch.cgi',
31       'SCRIPT_FILENAME' => '/home/mark/real/path/cgi-bin/dispatch.cgi',
32
33       # These two are added by mod_rewrite Ref: http://httpd.apache.org/docs/2.2/mod/mod_rewrite.html
34
35       'SCRIPT_URL'      => '/real/path/info',
36       'SCRIPT_URI'      => 'http://example.com/real/path/info',
37
38       'PATH_INFO'       => '/path/info',
39       'REQUEST_URI'     => '/real/path/info',
40       'HTTP_HOST'       => 'example.com'
41     );
42
43     my $q = CGI->new;
44
45     is(
46         $q->url( -absolute => 1, -query => 1, -path_info => 1 ),
47         '/real/path/info',
48         '$q->url( -absolute => 1, -query => 1, -path_info => 1 ) should return complete path, even when mod_rewrite is detected.'
49     );
50     is( $q->url(), 'http://example.com/real', '$q->url(), with rewriting detected' );
51     is( $q->url(-full=>1), 'http://example.com/real', '$q->url(-full=>1), with rewriting detected' );
52     is( $q->url(-path=>1), 'http://example.com/real/path/info', '$q->url(-path=>1), with rewriting detected' );
53     is( $q->url(-path=>0), 'http://example.com/real', '$q->url(-path=>0), with rewriting detected' );
54     is( $q->url(-full=>1,-path=>1), 'http://example.com/real/path/info', '$q->url(-full=>1,-path=>1), with rewriting detected' );
55     is( $q->url(-rewrite=>1,-path=>0), 'http://example.com/real', '$q->url(-rewrite=>1,-path=>0), with rewriting detected' );
56     is( $q->url(-rewrite=>1), 'http://example.com/real',
57                                                 '$q->url(-rewrite=>1), with rewriting detected' );
58     is( $q->url(-rewrite=>0), 'http://example.com/real/cgi-bin/dispatch.cgi',
59                                                 '$q->url(-rewrite=>0), with rewriting detected' );
60     is( $q->url(-rewrite=>0,-path=>1), 'http://example.com/real/cgi-bin/dispatch.cgi/path/info',
61                                                 '$q->url(-rewrite=>0,-path=>1), with rewriting detected' );
62     is( $q->url(-rewrite=>1,-path=>1), 'http://example.com/real/path/info',
63                                                 '$q->url(-rewrite=>1,-path=>1), with rewriting detected' );
64     is( $q->url(-rewrite=>0,-path=>0), 'http://example.com/real/cgi-bin/dispatch.cgi',
65                                                 '$q->url(-rewrite=>0,-path=>1), with rewriting detected' );
66 };
67
68
69 done_testing();
70
71