| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | ################################################################# | 
| 2 |  |  |  |  |  |  | #  Copyright (c) 2001, Raphael Manfredi | 
| 3 |  |  |  |  |  |  | #  Copyright (c) 2011-2015, Alex Tokarev | 
| 4 |  |  |  |  |  |  | # | 
| 5 |  |  |  |  |  |  | #  You may redistribute only under the terms of the Artistic License, | 
| 6 |  |  |  |  |  |  | #  as specified in the README file that comes with the distribution. | 
| 7 |  |  |  |  |  |  | # | 
| 8 |  |  |  |  |  |  |  | 
| 9 |  |  |  |  |  |  | package CGI::Test; | 
| 10 |  |  |  |  |  |  |  | 
| 11 | 23 |  |  | 23 |  | 392717 | use strict; | 
|  | 23 |  |  |  |  | 43 |  | 
|  | 23 |  |  |  |  | 674 |  | 
| 12 | 23 |  |  | 23 |  | 76 | use warnings; | 
|  | 23 |  |  |  |  | 25 |  | 
|  | 23 |  |  |  |  | 428 |  | 
| 13 |  |  |  |  |  |  |  | 
| 14 | 23 |  |  | 23 |  | 287 | use Carp; | 
|  | 23 |  |  |  |  | 32 |  | 
|  | 23 |  |  |  |  | 1415 |  | 
| 15 | 23 |  |  | 23 |  | 8913 | use HTTP::Status; | 
|  | 23 |  |  |  |  | 54820 |  | 
|  | 23 |  |  |  |  | 4253 |  | 
| 16 | 23 |  |  | 23 |  | 13222 | use URI; | 
|  | 23 |  |  |  |  | 91829 |  | 
|  | 23 |  |  |  |  | 571 |  | 
| 17 | 23 |  |  | 23 |  | 13480 | use File::Temp qw(mkstemp); | 
|  | 23 |  |  |  |  | 298532 |  | 
|  | 23 |  |  |  |  | 1188 |  | 
| 18 | 23 |  |  | 23 |  | 122 | use File::Spec; | 
|  | 23 |  |  |  |  | 28 |  | 
|  | 23 |  |  |  |  | 306 |  | 
| 19 | 23 |  |  | 23 |  | 64 | use File::Basename; | 
|  | 23 |  |  |  |  | 27 |  | 
|  | 23 |  |  |  |  | 1231 |  | 
| 20 | 23 |  |  | 23 |  | 85 | use Cwd qw(abs_path); | 
|  | 23 |  |  |  |  | 23 |  | 
|  | 23 |  |  |  |  | 730 |  | 
| 21 |  |  |  |  |  |  |  | 
| 22 | 23 |  |  | 23 |  | 210 | use vars qw($VERSION); | 
|  | 23 |  |  |  |  | 23 |  | 
|  | 23 |  |  |  |  | 1505 |  | 
| 23 |  |  |  |  |  |  |  | 
| 24 |  |  |  |  |  |  | $VERSION = '1.110'; | 
| 25 |  |  |  |  |  |  |  | 
| 26 | 23 |  |  | 23 |  | 76 | use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; | 
|  | 23 |  |  |  |  | 27 |  | 
|  | 23 |  |  |  |  | 21 |  | 
|  | 23 |  |  |  |  | 61893 |  | 
| 27 |  |  |  |  |  |  |  | 
| 28 |  |  |  |  |  |  | ############################################################################# | 
| 29 |  |  |  |  |  |  | # | 
| 30 |  |  |  |  |  |  | # ->new | 
| 31 |  |  |  |  |  |  | # | 
| 32 |  |  |  |  |  |  | # Creation routine | 
| 33 |  |  |  |  |  |  | # | 
| 34 |  |  |  |  |  |  | # Arguments: | 
| 35 |  |  |  |  |  |  | #    base_url		URL to cgi-bin, e.g. http://foo:18/cgi-bin | 
| 36 |  |  |  |  |  |  | #    cgi_dir		physical location of base_url | 
| 37 |  |  |  |  |  |  | #    tmp_dir		(optional) temporary directory to use | 
| 38 |  |  |  |  |  |  | #    cgi_env		(optional) default CGI environment | 
| 39 |  |  |  |  |  |  | #    doc_dir		(optional) physical location of docs, for path translation | 
| 40 |  |  |  |  |  |  | # | 
| 41 |  |  |  |  |  |  | ############################################################################# | 
| 42 |  |  |  |  |  |  | sub new | 
| 43 |  |  |  |  |  |  | { | 
| 44 | 25 |  |  | 25 | 0 | 28910 | my $this = bless {}, shift; | 
| 45 | 25 |  |  |  |  | 96 | my %params = @_; | 
| 46 |  |  |  |  |  |  |  | 
| 47 | 25 |  |  |  |  | 65 | my $ubase = $params{-base_url}; | 
| 48 | 25 |  |  |  |  | 57 | my $dir   = $params{-cgi_dir}; | 
| 49 | 25 |  | 50 |  |  | 146 | my $doc   = $params{-doc_dir} || "."; | 
| 50 | 25 |  | 50 |  |  | 293 | my $tmp   = $params{-tmp_dir} || $ENV{TMPDIR} || $ENV{TEMP} || "/tmp"; | 
| 51 | 25 |  |  |  |  | 53 | my $env   = $params{-cgi_env}; | 
| 52 |  |  |  |  |  |  |  | 
| 53 | 25 |  |  |  |  | 190 | my $uri = URI->new($ubase); | 
| 54 | 25 | 50 |  |  |  | 115775 | croak "-base_url $ubase is not within the http scheme" | 
| 55 |  |  |  |  |  |  | unless $uri->scheme eq 'http'; | 
| 56 |  |  |  |  |  |  |  | 
| 57 | 25 |  |  |  |  | 2689 | my ($server, $path) = $this->split_uri($uri); | 
| 58 | 25 |  |  |  |  | 270 | $this->{host_port} = $server; | 
| 59 | 25 |  |  |  |  | 69 | $this->{scheme}    = $uri->scheme; | 
| 60 | 25 |  |  |  |  | 292 | $this->{host}      = $uri->host; | 
| 61 | 25 |  |  |  |  | 550 | $this->{port}      = $uri->port; | 
| 62 | 25 |  |  |  |  | 389 | $this->{base_path} = $path; | 
| 63 | 25 |  |  |  |  | 38 | $this->{cgi_dir}   = $dir; | 
| 64 | 25 |  |  |  |  | 42 | $this->{tmp_dir}   = $tmp; | 
| 65 | 25 | 100 |  |  |  | 75 | $env = {} unless defined $env; | 
| 66 | 25 |  |  |  |  | 54 | $this->{cgi_env} = $env; | 
| 67 | 25 |  |  |  |  | 42 | $this->{doc_dir} = $doc; | 
| 68 |  |  |  |  |  |  |  | 
| 69 |  |  |  |  |  |  | # | 
| 70 |  |  |  |  |  |  | # The following default settings will apply unless alternatives given | 
| 71 |  |  |  |  |  |  | # by user via the -cgi_env parameter. | 
| 72 |  |  |  |  |  |  | # | 
| 73 |  |  |  |  |  |  |  | 
| 74 | 25 |  |  |  |  | 108 | my %dflt = (AUTH_TYPE           => "Basic", | 
| 75 |  |  |  |  |  |  | GATEWAY_INTERFACE   => "CGI/1.1", | 
| 76 |  |  |  |  |  |  | HTTP_ACCEPT         => "*/*", | 
| 77 |  |  |  |  |  |  | HTTP_CONNECTION     => "Close", | 
| 78 |  |  |  |  |  |  | HTTP_USER_AGENT     => "CGI::Test", | 
| 79 |  |  |  |  |  |  | HTTP_ACCEPT_CHARSET => "iso-8859-1", | 
| 80 |  |  |  |  |  |  | REMOTE_HOST         => "localhost", | 
| 81 |  |  |  |  |  |  | REMOTE_ADDR         => "127.0.0.1", | 
| 82 |  |  |  |  |  |  | SERVER_NAME         => $uri->host, | 
| 83 |  |  |  |  |  |  | SERVER_PORT         => $uri->port, | 
| 84 |  |  |  |  |  |  | SERVER_PROTOCOL     => "HTTP/1.1", | 
| 85 |  |  |  |  |  |  | SERVER_SOFTWARE     => "CGI::Test", | 
| 86 |  |  |  |  |  |  | ); | 
| 87 |  |  |  |  |  |  |  | 
| 88 | 25 |  |  |  |  | 872 | while (my ($key, $value) = each %dflt) | 
| 89 |  |  |  |  |  |  | { | 
| 90 | 300 | 100 |  |  |  | 786 | $env->{$key} = $value unless exists $env->{$key}; | 
| 91 |  |  |  |  |  |  | } | 
| 92 |  |  |  |  |  |  |  | 
| 93 |  |  |  |  |  |  | # | 
| 94 |  |  |  |  |  |  | # Object types to create depending on returned content-type. | 
| 95 |  |  |  |  |  |  | # If not listed here, "Other" is assummed. | 
| 96 |  |  |  |  |  |  | # | 
| 97 |  |  |  |  |  |  |  | 
| 98 | 25 |  |  |  |  | 84 | $this->{_obj_type} = {'text/plain' => 'Text', | 
| 99 |  |  |  |  |  |  | 'text/html'  => 'HTML', | 
| 100 |  |  |  |  |  |  | }; | 
| 101 |  |  |  |  |  |  |  | 
| 102 | 25 |  |  |  |  | 271 | return $this; | 
| 103 |  |  |  |  |  |  | } | 
| 104 |  |  |  |  |  |  |  | 
| 105 |  |  |  |  |  |  | ###################################################################### | 
| 106 |  |  |  |  |  |  | # | 
| 107 |  |  |  |  |  |  | ###################################################################### | 
| 108 |  |  |  |  |  |  | sub make | 
| 109 |  |  |  |  |  |  | { | 
| 110 | 0 |  |  | 0 | 0 | 0 | my $class = shift; | 
| 111 | 0 |  |  |  |  | 0 | return $class->new(@_); | 
| 112 |  |  |  |  |  |  | } | 
| 113 |  |  |  |  |  |  |  | 
| 114 |  |  |  |  |  |  | # | 
| 115 |  |  |  |  |  |  | # Attribute access | 
| 116 |  |  |  |  |  |  | # | 
| 117 |  |  |  |  |  |  |  | 
| 118 |  |  |  |  |  |  | ###################################################################### | 
| 119 |  |  |  |  |  |  | sub host_port | 
| 120 |  |  |  |  |  |  | { | 
| 121 | 44 |  |  | 44 | 1 | 65 | my $this = shift; | 
| 122 | 44 |  |  |  |  | 97 | return $this->{host_port}; | 
| 123 |  |  |  |  |  |  | } | 
| 124 |  |  |  |  |  |  |  | 
| 125 |  |  |  |  |  |  | ###################################################################### | 
| 126 |  |  |  |  |  |  | sub base_uri | 
| 127 |  |  |  |  |  |  | { | 
| 128 | 0 |  |  | 0 | 0 | 0 | my $this = shift; | 
| 129 |  |  |  |  |  |  |  | 
| 130 | 0 |  |  |  |  | 0 | my $scheme = $this->{scheme}; | 
| 131 | 0 |  |  |  |  | 0 | my $host   = $this->{host}; | 
| 132 | 0 |  |  |  |  | 0 | my $port   = $this->{port}; | 
| 133 | 0 |  |  |  |  | 0 | my $base   = $this->{base_path}; | 
| 134 |  |  |  |  |  |  |  | 
| 135 | 0 |  |  |  |  | 0 | return $scheme . '://' . $host . ':' . $port . $base; | 
| 136 |  |  |  |  |  |  | } | 
| 137 |  |  |  |  |  |  |  | 
| 138 |  |  |  |  |  |  | ###################################################################### | 
| 139 |  |  |  |  |  |  | sub host | 
| 140 |  |  |  |  |  |  | { | 
| 141 | 0 |  |  | 0 | 0 | 0 | my $this = shift; | 
| 142 | 0 |  |  |  |  | 0 | return $this->{host}; | 
| 143 |  |  |  |  |  |  | } | 
| 144 |  |  |  |  |  |  |  | 
| 145 |  |  |  |  |  |  | ###################################################################### | 
| 146 |  |  |  |  |  |  | sub port | 
| 147 |  |  |  |  |  |  | { | 
| 148 | 0 |  |  | 0 | 0 | 0 | my $this = shift; | 
| 149 | 0 |  |  |  |  | 0 | return $this->{port}; | 
| 150 |  |  |  |  |  |  | } | 
| 151 |  |  |  |  |  |  |  | 
| 152 |  |  |  |  |  |  | ###################################################################### | 
| 153 |  |  |  |  |  |  | sub base_path | 
| 154 |  |  |  |  |  |  | { | 
| 155 | 44 |  |  | 44 | 1 | 53 | my $this = shift; | 
| 156 | 44 |  |  |  |  | 141 | return $this->{base_path}; | 
| 157 |  |  |  |  |  |  | } | 
| 158 |  |  |  |  |  |  |  | 
| 159 |  |  |  |  |  |  | ###################################################################### | 
| 160 |  |  |  |  |  |  | sub cgi_dir | 
| 161 |  |  |  |  |  |  | { | 
| 162 | 44 |  |  | 44 | 1 | 56 | my $this = shift; | 
| 163 | 44 |  |  |  |  | 120 | return $this->{cgi_dir}; | 
| 164 |  |  |  |  |  |  | } | 
| 165 |  |  |  |  |  |  |  | 
| 166 |  |  |  |  |  |  | ###################################################################### | 
| 167 |  |  |  |  |  |  | sub doc_dir | 
| 168 |  |  |  |  |  |  | { | 
| 169 | 16 |  |  | 16 | 1 | 47 | my $this = shift; | 
| 170 | 16 |  |  |  |  | 148 | return $this->{doc_dir}; | 
| 171 |  |  |  |  |  |  | } | 
| 172 |  |  |  |  |  |  |  | 
| 173 |  |  |  |  |  |  | ###################################################################### | 
| 174 |  |  |  |  |  |  | sub tmp_dir | 
| 175 |  |  |  |  |  |  | { | 
| 176 | 62 |  |  | 62 | 1 | 97 | my $this = shift; | 
| 177 | 62 |  |  |  |  | 772 | return $this->{tmp_dir}; | 
| 178 |  |  |  |  |  |  | } | 
| 179 |  |  |  |  |  |  |  | 
| 180 |  |  |  |  |  |  | ###################################################################### | 
| 181 |  |  |  |  |  |  | sub cgi_env | 
| 182 |  |  |  |  |  |  | { | 
| 183 | 210 |  |  | 210 | 0 | 233 | my $this = shift; | 
| 184 | 210 |  |  |  |  | 2173 | return $this->{cgi_env}; | 
| 185 |  |  |  |  |  |  | } | 
| 186 |  |  |  |  |  |  |  | 
| 187 |  |  |  |  |  |  | ###################################################################### | 
| 188 |  |  |  |  |  |  | sub _obj_type | 
| 189 |  |  |  |  |  |  | { | 
| 190 | 28 |  |  | 28 |  | 55 | my $this = shift; | 
| 191 | 28 |  |  |  |  | 205 | return $this->{_obj_type}; | 
| 192 |  |  |  |  |  |  | } | 
| 193 |  |  |  |  |  |  |  | 
| 194 |  |  |  |  |  |  | ###################################################################### | 
| 195 |  |  |  |  |  |  | sub http_headers { | 
| 196 | 0 |  |  | 0 | 1 | 0 | my ($self) = @_; | 
| 197 |  |  |  |  |  |  |  | 
| 198 | 0 |  |  |  |  | 0 | return $self->{http_headers}; | 
| 199 |  |  |  |  |  |  | } | 
| 200 |  |  |  |  |  |  |  | 
| 201 |  |  |  |  |  |  | ###################################################################### | 
| 202 |  |  |  |  |  |  | # | 
| 203 |  |  |  |  |  |  | # ->_dpath | 
| 204 |  |  |  |  |  |  | # | 
| 205 |  |  |  |  |  |  | # Returns direct path to final component of argument, | 
| 206 |  |  |  |  |  |  | # i.e. the original path with . and .. items removed. | 
| 207 |  |  |  |  |  |  | # | 
| 208 |  |  |  |  |  |  | # Will probably only work on Unix (possibly Win32 if paths given with "/"). | 
| 209 |  |  |  |  |  |  | # | 
| 210 |  |  |  |  |  |  | ###################################################################### | 
| 211 |  |  |  |  |  |  | sub _dpath | 
| 212 |  |  |  |  |  |  | { | 
| 213 | 69 |  |  | 69 |  | 2104 | my $this  = shift; | 
| 214 | 69 |  |  |  |  | 100 | my ($dir) = @_; | 
| 215 | 69 | 50 |  |  |  | 313 | my $root  = ($dir =~ s|^/||) ? "/" : ""; | 
| 216 | 69 |  |  |  |  | 83 | my @cur; | 
| 217 | 69 |  |  |  |  | 244 | foreach my $item (split(m|/|, $dir)) | 
| 218 |  |  |  |  |  |  | { | 
| 219 | 119 | 50 |  |  |  | 477 | next if $item eq '.'; | 
| 220 | 119 | 50 |  |  |  | 189 | if ($item eq '..') | 
| 221 |  |  |  |  |  |  | { | 
| 222 | 0 |  |  |  |  | 0 | pop(@cur); | 
| 223 |  |  |  |  |  |  | } | 
| 224 |  |  |  |  |  |  | else | 
| 225 |  |  |  |  |  |  | { | 
| 226 | 119 |  |  |  |  | 350 | push(@cur, $item); | 
| 227 |  |  |  |  |  |  | } | 
| 228 |  |  |  |  |  |  | } | 
| 229 | 69 |  |  |  |  | 206 | my $path = $root . join('/', @cur); | 
| 230 | 69 |  |  |  |  | 438 | $path =~ tr|/||s; | 
| 231 | 69 |  |  |  |  | 315 | return $path; | 
| 232 |  |  |  |  |  |  | } | 
| 233 |  |  |  |  |  |  |  | 
| 234 |  |  |  |  |  |  | ###################################################################### | 
| 235 |  |  |  |  |  |  | # | 
| 236 |  |  |  |  |  |  | # ->split_uri | 
| 237 |  |  |  |  |  |  | # | 
| 238 |  |  |  |  |  |  | # Split down URI into (server, path, query) components. | 
| 239 |  |  |  |  |  |  | # | 
| 240 |  |  |  |  |  |  | ###################################################################### | 
| 241 |  |  |  |  |  |  | sub split_uri | 
| 242 |  |  |  |  |  |  | { | 
| 243 | 69 |  |  | 69 | 1 | 91 | my $this = shift; | 
| 244 | 69 |  |  |  |  | 103 | my ($uri) = @_; | 
| 245 | 69 |  |  |  |  | 392 | return ($uri->host_port, $this->_dpath($uri->path), $uri->query); | 
| 246 |  |  |  |  |  |  | } | 
| 247 |  |  |  |  |  |  |  | 
| 248 |  |  |  |  |  |  | ###################################################################### | 
| 249 |  |  |  |  |  |  | # | 
| 250 |  |  |  |  |  |  | # ->GET | 
| 251 |  |  |  |  |  |  | # | 
| 252 |  |  |  |  |  |  | # Perform an HTTP GET request on a CGI URI by running the script directly. | 
| 253 |  |  |  |  |  |  | # Returns a CGI::Test::Page object representing the returned page, or the | 
| 254 |  |  |  |  |  |  | # error. | 
| 255 |  |  |  |  |  |  | # | 
| 256 |  |  |  |  |  |  | # Optional $user provides the name of the "authenticated" user running | 
| 257 |  |  |  |  |  |  | # this script. | 
| 258 |  |  |  |  |  |  | # | 
| 259 |  |  |  |  |  |  | ###################################################################### | 
| 260 |  |  |  |  |  |  | sub GET | 
| 261 |  |  |  |  |  |  | { | 
| 262 | 42 |  |  | 42 | 1 | 6769 | my $this = shift; | 
| 263 | 42 |  |  |  |  | 65 | my ($uri, $user) = @_; | 
| 264 |  |  |  |  |  |  |  | 
| 265 | 42 |  |  |  |  | 162 | return $this->_cgi_request($uri, $user, undef); | 
| 266 |  |  |  |  |  |  | } | 
| 267 |  |  |  |  |  |  |  | 
| 268 |  |  |  |  |  |  | ###################################################################### | 
| 269 |  |  |  |  |  |  | # | 
| 270 |  |  |  |  |  |  | # ->POST | 
| 271 |  |  |  |  |  |  | # | 
| 272 |  |  |  |  |  |  | # Perform an HTTP POST request on a CGI URI by running the script directly. | 
| 273 |  |  |  |  |  |  | # Returns a CGI::Test::Page object representing the returned page, or the | 
| 274 |  |  |  |  |  |  | # error. | 
| 275 |  |  |  |  |  |  | # | 
| 276 |  |  |  |  |  |  | # Data to send to the script are held in $input, a CGI::Test::Input object. | 
| 277 |  |  |  |  |  |  | # | 
| 278 |  |  |  |  |  |  | # Optional $user provides the name of the "authenticated" user running | 
| 279 |  |  |  |  |  |  | # this script. | 
| 280 |  |  |  |  |  |  | # | 
| 281 |  |  |  |  |  |  | ###################################################################### | 
| 282 |  |  |  |  |  |  | sub POST | 
| 283 |  |  |  |  |  |  | { | 
| 284 | 2 |  |  | 2 | 1 | 2 | my $this = shift; | 
| 285 | 2 |  |  |  |  | 4 | my ($uri, $input, $user) = @_; | 
| 286 |  |  |  |  |  |  |  | 
| 287 | 2 |  |  |  |  | 8 | return $this->_cgi_request($uri, $user, $input); | 
| 288 |  |  |  |  |  |  | } | 
| 289 |  |  |  |  |  |  |  | 
| 290 |  |  |  |  |  |  | ###################################################################### | 
| 291 |  |  |  |  |  |  | # | 
| 292 |  |  |  |  |  |  | # ->_cgi_request | 
| 293 |  |  |  |  |  |  | # | 
| 294 |  |  |  |  |  |  | # Common routine to handle GET and POST. | 
| 295 |  |  |  |  |  |  | # | 
| 296 |  |  |  |  |  |  | ###################################################################### | 
| 297 |  |  |  |  |  |  | sub _cgi_request | 
| 298 |  |  |  |  |  |  | { | 
| 299 | 44 |  |  | 44 |  | 53 | my $this = shift; | 
| 300 | 44 |  |  |  |  | 63 | my ($uri, $user, $input) = @_;    # $input defined for POST | 
| 301 |  |  |  |  |  |  |  | 
| 302 | 44 |  |  |  |  | 151 | my $u = URI->new($uri); | 
| 303 | 44 | 50 |  |  |  | 2157 | croak "URI $uri is not within the http scheme" | 
| 304 |  |  |  |  |  |  | unless $u->scheme eq 'http'; | 
| 305 |  |  |  |  |  |  |  | 
| 306 | 44 |  |  |  |  | 9661 | require CGI::Test::Page::Error; | 
| 307 | 44 |  |  |  |  | 85 | my $error = "CGI::Test::Page::Error"; | 
| 308 |  |  |  |  |  |  |  | 
| 309 | 44 |  |  |  |  | 135 | my ($userver, $upath, $uquery) = $this->split_uri($u); | 
| 310 | 44 |  |  |  |  | 510 | my $server    = $this->host_port; | 
| 311 | 44 |  |  |  |  | 140 | my $base_path = $this->base_path . "/"; | 
| 312 |  |  |  |  |  |  |  | 
| 313 | 44 | 50 |  |  |  | 131 | croak "URI $uri is not located on server $server" | 
| 314 |  |  |  |  |  |  | unless $userver eq $server; | 
| 315 |  |  |  |  |  |  |  | 
| 316 | 44 | 50 |  |  |  | 154 | croak "URI $uri is not located under the $base_path directory" | 
| 317 |  |  |  |  |  |  | unless substr($upath, 0, length $base_path) eq $base_path; | 
| 318 |  |  |  |  |  |  |  | 
| 319 | 44 |  |  |  |  | 106 | substr($upath, 0, length $base_path) = ''; | 
| 320 |  |  |  |  |  |  |  | 
| 321 |  |  |  |  |  |  | # | 
| 322 |  |  |  |  |  |  | # We have script + path_info in the $upath variable.  To determine where | 
| 323 |  |  |  |  |  |  | # the path_info starts, we have to walk through the components and | 
| 324 |  |  |  |  |  |  | # compare, at each step, the current walk-through path with one on the | 
| 325 |  |  |  |  |  |  | # filesystem under cgi_dir. | 
| 326 |  |  |  |  |  |  | # | 
| 327 |  |  |  |  |  |  |  | 
| 328 | 44 |  |  |  |  | 106 | my $cgi_dir = $this->cgi_dir; | 
| 329 | 44 |  |  |  |  | 137 | my @components = split(m|/|, $upath); | 
| 330 | 44 |  |  |  |  | 48 | my @script; | 
| 331 |  |  |  |  |  |  |  | 
| 332 | 44 |  |  |  |  | 117 | while (@components) | 
| 333 |  |  |  |  |  |  | { | 
| 334 | 47 |  |  |  |  | 60 | my $item = shift @components; | 
| 335 | 47 | 100 |  |  |  | 1480 | if (-e File::Spec->catfile($cgi_dir, @script, $item)) | 
| 336 |  |  |  |  |  |  | { | 
| 337 | 44 |  |  |  |  | 148 | push(@script, $item); | 
| 338 |  |  |  |  |  |  | } | 
| 339 |  |  |  |  |  |  | else | 
| 340 |  |  |  |  |  |  | { | 
| 341 | 3 |  |  |  |  | 3 | unshift @components, $item; | 
| 342 | 3 |  |  |  |  | 6 | last; | 
| 343 |  |  |  |  |  |  | } | 
| 344 |  |  |  |  |  |  | } | 
| 345 |  |  |  |  |  |  |  | 
| 346 | 44 |  |  |  |  | 230 | my $script      = File::Spec->catfile($cgi_dir, @script);        # Real | 
| 347 | 44 |  |  |  |  | 105 | my $script_name = $base_path . join("/",        @script);        # Virtual | 
| 348 | 44 |  |  |  |  | 82 | my $path        = "/" . join("/",               @components);    # Virtual | 
| 349 |  |  |  |  |  |  |  | 
| 350 | 44 | 50 |  |  |  | 313 | return $error->new(RC_NOT_FOUND,    $this) unless -f $script; | 
| 351 | 44 | 50 |  |  |  | 300 | return $error->new(RC_UNAUTHORIZED, $this) unless -x $script; | 
| 352 |  |  |  |  |  |  |  | 
| 353 |  |  |  |  |  |  | # | 
| 354 |  |  |  |  |  |  | # Prepare input for POST requests. | 
| 355 |  |  |  |  |  |  | # | 
| 356 |  |  |  |  |  |  |  | 
| 357 | 44 |  |  |  |  | 71 | my @post = (); | 
| 358 | 44 |  |  |  |  | 671 | local $SIG{PIPE} = 'IGNORE'; | 
| 359 | 44 |  |  |  |  | 140 | local (*PREAD, *PWRITE); | 
| 360 |  |  |  |  |  |  |  | 
| 361 | 44 |  |  |  |  | 52 | my ($in_fh, $out_fh, $in_fname, $out_fname); | 
| 362 |  |  |  |  |  |  |  | 
| 363 | 44 | 100 |  |  |  | 113 | if (defined $input) { | 
| 364 |  |  |  |  |  |  | # In Windows, we use temp files instead of pipes to avoid | 
| 365 |  |  |  |  |  |  | # stream duplication errors | 
| 366 | 2 | 50 |  |  |  | 10 | if ( WINDOWS ) { | 
| 367 | 0 |  |  |  |  | 0 | ($in_fh, $in_fname) = | 
| 368 |  |  |  |  |  |  | mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_in.XXXXXX")); | 
| 369 |  |  |  |  |  |  |  | 
| 370 | 0 |  |  |  |  | 0 | binmode $in_fh; | 
| 371 |  |  |  |  |  |  |  | 
| 372 | 0 |  |  |  |  | 0 | syswrite $in_fh, $input->data, $input->length; | 
| 373 | 0 |  |  |  |  | 0 | close $in_fh; | 
| 374 |  |  |  |  |  |  |  | 
| 375 | 0 |  |  |  |  | 0 | @post = ( | 
| 376 |  |  |  |  |  |  | -in_fname => $in_fname, | 
| 377 |  |  |  |  |  |  | -input    => $input, | 
| 378 |  |  |  |  |  |  | ); | 
| 379 |  |  |  |  |  |  | } | 
| 380 |  |  |  |  |  |  | else { | 
| 381 | 2 | 50 |  |  |  | 30 | if ( not pipe(PREAD, PWRITE) ) { | 
| 382 | 0 |  |  |  |  | 0 | warn "can't open pipe: $!"; | 
| 383 | 0 |  |  |  |  | 0 | return $error->new(RC_INTERNAL_SERVER_ERROR, $this); | 
| 384 |  |  |  |  |  |  | } | 
| 385 |  |  |  |  |  |  |  | 
| 386 |  |  |  |  |  |  | @post = ( | 
| 387 | 2 |  |  |  |  | 12 | -in    => \*PREAD, | 
| 388 |  |  |  |  |  |  | -input => $input, | 
| 389 |  |  |  |  |  |  | ); | 
| 390 |  |  |  |  |  |  | } | 
| 391 |  |  |  |  |  |  | } | 
| 392 |  |  |  |  |  |  |  | 
| 393 |  |  |  |  |  |  | # | 
| 394 |  |  |  |  |  |  | # Prepare temporary file for storing output, which we'll parse once | 
| 395 |  |  |  |  |  |  | # the script is done. | 
| 396 |  |  |  |  |  |  | # | 
| 397 |  |  |  |  |  |  |  | 
| 398 | 44 |  |  |  |  | 154 | ($out_fh, $out_fname) = | 
| 399 |  |  |  |  |  |  | mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_out.XXXXXX")); | 
| 400 |  |  |  |  |  |  |  | 
| 401 | 44 | 50 |  |  |  | 13853 | close $out_fh if WINDOWS; | 
| 402 |  |  |  |  |  |  |  | 
| 403 | 44 |  |  |  |  | 315 | select((select(STDOUT), $| = 1)[ 0 ]); | 
| 404 | 44 |  |  |  |  | 122 | print STDOUT "";    # Flush STDOUT before forking | 
| 405 |  |  |  |  |  |  |  | 
| 406 |  |  |  |  |  |  | # | 
| 407 |  |  |  |  |  |  | # Fork... | 
| 408 |  |  |  |  |  |  | # | 
| 409 |  |  |  |  |  |  |  | 
| 410 | 44 |  |  |  |  | 28736 | my $pid = fork; | 
| 411 | 44 | 50 |  |  |  | 1287 | die "can't fork: $!" unless defined $pid; | 
| 412 |  |  |  |  |  |  |  | 
| 413 |  |  |  |  |  |  | # | 
| 414 |  |  |  |  |  |  | # Child will run the CGI program with no input if it's a GET and | 
| 415 |  |  |  |  |  |  | # output stored to $fh.  When issuing a POST, data will be provided | 
| 416 |  |  |  |  |  |  | # by the parent through a pipe in Unixy systems, or through a temp file | 
| 417 |  |  |  |  |  |  | # in Windows. | 
| 418 |  |  |  |  |  |  | # | 
| 419 |  |  |  |  |  |  |  | 
| 420 | 44 | 100 |  |  |  | 1146 | if ($pid == 0) { | 
| 421 | 16 | 100 | 66 |  |  | 696 | close PWRITE if defined $input && !WINDOWS; # Writing side of the pipe | 
| 422 |  |  |  |  |  |  |  | 
| 423 | 16 |  |  |  |  | 1322 | $this->_run_cgi( | 
| 424 |  |  |  |  |  |  | -script_file => $script,         # Real path | 
| 425 |  |  |  |  |  |  | -script_name => $script_name,    # Virtual path, given in URI | 
| 426 |  |  |  |  |  |  | -user        => $user, | 
| 427 |  |  |  |  |  |  | -out         => $out_fh, | 
| 428 |  |  |  |  |  |  | -out_fname   => $out_fname, | 
| 429 |  |  |  |  |  |  | -uri         => $u, | 
| 430 |  |  |  |  |  |  | -path_info   => $path, | 
| 431 |  |  |  |  |  |  | @post,                           # Additional params for POST | 
| 432 |  |  |  |  |  |  | ); | 
| 433 |  |  |  |  |  |  |  | 
| 434 | 0 |  |  |  |  | 0 | confess "not reachable!"; | 
| 435 |  |  |  |  |  |  | } | 
| 436 |  |  |  |  |  |  |  | 
| 437 |  |  |  |  |  |  | # | 
| 438 |  |  |  |  |  |  | # Parent process | 
| 439 |  |  |  |  |  |  | # | 
| 440 |  |  |  |  |  |  |  | 
| 441 | 28 | 50 |  |  |  | 1514 | close $out_fh unless WINDOWS; | 
| 442 |  |  |  |  |  |  |  | 
| 443 | 28 | 100 | 66 |  |  | 219 | if (defined $input && !WINDOWS) | 
| 444 |  |  |  |  |  |  | {                                        # Send POST input data | 
| 445 | 1 |  |  |  |  | 15 | close PREAD; | 
| 446 | 1 |  |  |  |  | 47 | syswrite PWRITE, $input->data, $input->length; | 
| 447 | 1 | 50 |  |  |  | 7 | close PWRITE or warn "failure while closing pipe: $!"; | 
| 448 |  |  |  |  |  |  | } | 
| 449 |  |  |  |  |  |  |  | 
| 450 | 28 |  |  |  |  | 17700704 | my $child = waitpid $pid, 0; | 
| 451 |  |  |  |  |  |  |  | 
| 452 | 28 | 50 |  |  |  | 268 | if ($pid != $child) | 
| 453 |  |  |  |  |  |  | { | 
| 454 | 0 |  |  |  |  | 0 | warn "waitpid returned with pid=$child, but expected pid=$pid"; | 
| 455 | 0 | 0 |  |  |  | 0 | kill 'TERM', $pid or warn "can't SIGTERM pid $pid: $!"; | 
| 456 | 0 | 0 |  |  |  | 0 | unlink $in_fname  or warn "can't unlink $in_fname: $!"; | 
| 457 | 0 | 0 |  |  |  | 0 | unlink $out_fname or warn "can't unlink $out_fname: $!"; | 
| 458 | 0 |  |  |  |  | 0 | return $error->new(RC_NO_CONTENT, $this); | 
| 459 |  |  |  |  |  |  | } | 
| 460 |  |  |  |  |  |  |  | 
| 461 |  |  |  |  |  |  | # | 
| 462 |  |  |  |  |  |  | # Get header within generated response, and determine Content-Type. | 
| 463 |  |  |  |  |  |  | # | 
| 464 |  |  |  |  |  |  |  | 
| 465 | 28 |  |  |  |  | 421 | my $header = $this->_parse_header($out_fname); | 
| 466 | 28 | 50 |  |  |  | 154 | unless (scalar keys %$header) | 
| 467 |  |  |  |  |  |  | { | 
| 468 | 0 |  |  |  |  | 0 | warn "script $script_name generated no valid headers"; | 
| 469 | 0 | 0 |  |  |  | 0 | unlink $in_fname  or warn "can't unlink $in_fname: $!"; | 
| 470 | 0 | 0 |  |  |  | 0 | unlink $out_fname or warn "can't unlink $out_fname: $!"; | 
| 471 | 0 |  |  |  |  | 0 | return $error->new(RC_INTERNAL_SERVER_ERROR, $this); | 
| 472 |  |  |  |  |  |  | } | 
| 473 |  |  |  |  |  |  |  | 
| 474 |  |  |  |  |  |  | # | 
| 475 |  |  |  |  |  |  | # Return error page if we got 5xx status | 
| 476 |  |  |  |  |  |  | # | 
| 477 |  |  |  |  |  |  |  | 
| 478 | 28 | 50 | 50 |  |  | 315 | if ( my ($status) = ($header->{Status} || '') =~ /^(5\d\d)/ ) { | 
| 479 | 0 |  |  |  |  | 0 | return $error->new($status, $this); | 
| 480 |  |  |  |  |  |  | } | 
| 481 |  |  |  |  |  |  |  | 
| 482 |  |  |  |  |  |  | # | 
| 483 |  |  |  |  |  |  | # Store headers for later retrieval | 
| 484 |  |  |  |  |  |  | # | 
| 485 |  |  |  |  |  |  |  | 
| 486 | 28 |  |  |  |  | 97 | $this->{http_headers} = $header; | 
| 487 |  |  |  |  |  |  |  | 
| 488 |  |  |  |  |  |  | # | 
| 489 |  |  |  |  |  |  | # Create proper page object, which will parse the results file as needed. | 
| 490 |  |  |  |  |  |  | # | 
| 491 |  |  |  |  |  |  |  | 
| 492 | 28 |  |  |  |  | 120 | my $type      = $header->{'Content-Type'}; | 
| 493 | 28 |  |  |  |  | 70 | my $base_type = lc($type); | 
| 494 | 28 |  |  |  |  | 158 | $base_type =~ s/;.*//;    # Strip type parameters | 
| 495 | 28 |  | 50 |  |  | 189 | my $objtype = $this->_obj_type->{$base_type} || "Other"; | 
| 496 | 28 |  |  |  |  | 69 | $objtype = "CGI::Test::Page::$objtype"; | 
| 497 |  |  |  |  |  |  |  | 
| 498 | 28 |  |  |  |  | 3003 | eval "require $objtype"; | 
| 499 | 28 | 50 |  |  |  | 210 | die "can't load module $objtype: $@" if chop $@; | 
| 500 |  |  |  |  |  |  |  | 
| 501 | 28 |  |  |  |  | 322 | my $page = $objtype->new( | 
| 502 |  |  |  |  |  |  | -server       => $this, | 
| 503 |  |  |  |  |  |  | -file         => $out_fname, | 
| 504 |  |  |  |  |  |  | -content_type => $type,    # raw type, with parameters | 
| 505 |  |  |  |  |  |  | -user         => $user, | 
| 506 |  |  |  |  |  |  | -uri          => $u, | 
| 507 |  |  |  |  |  |  | ); | 
| 508 |  |  |  |  |  |  |  | 
| 509 | 28 | 50 |  |  |  | 108 | if ($in_fname) { | 
| 510 | 0 | 0 |  |  |  | 0 | unlink $in_fname  or warn "can't unlink $in_fname: $!"; | 
| 511 |  |  |  |  |  |  | } | 
| 512 |  |  |  |  |  |  |  | 
| 513 | 28 | 50 |  |  |  | 3053 | unlink $out_fname or warn "can't unlink $out_fname: $!"; | 
| 514 |  |  |  |  |  |  |  | 
| 515 | 28 |  |  |  |  | 837 | return $page; | 
| 516 |  |  |  |  |  |  | } | 
| 517 |  |  |  |  |  |  |  | 
| 518 |  |  |  |  |  |  | ###################################################################### | 
| 519 |  |  |  |  |  |  | # | 
| 520 |  |  |  |  |  |  | # ->_run_cgi | 
| 521 |  |  |  |  |  |  | # | 
| 522 |  |  |  |  |  |  | # Run the specified script within a CGI environment. | 
| 523 |  |  |  |  |  |  | # | 
| 524 |  |  |  |  |  |  | # The -user is the name of the authenticated user running this script. | 
| 525 |  |  |  |  |  |  | # | 
| 526 |  |  |  |  |  |  | # The -in and -out parameters are file handles where STDIN and STDOUT | 
| 527 |  |  |  |  |  |  | # need to be connected to.  If $in is undefined, STDIN is connected | 
| 528 |  |  |  |  |  |  | # to /dev/null. | 
| 529 |  |  |  |  |  |  | # | 
| 530 |  |  |  |  |  |  | # Returns nothing. | 
| 531 |  |  |  |  |  |  | # | 
| 532 |  |  |  |  |  |  | ###################################################################### | 
| 533 |  |  |  |  |  |  | sub _run_cgi | 
| 534 |  |  |  |  |  |  | { | 
| 535 | 16 |  |  | 16 |  | 192 | my $this = shift; | 
| 536 |  |  |  |  |  |  |  | 
| 537 | 16 |  |  |  |  | 702 | my %params = @_; | 
| 538 |  |  |  |  |  |  |  | 
| 539 | 16 |  |  |  |  | 146 | my $script    = $params{-script_file}; | 
| 540 | 16 |  |  |  |  | 104 | my $name      = $params{-script_name}; | 
| 541 | 16 |  |  |  |  | 98 | my $user      = $params{-user}; | 
| 542 | 16 |  |  |  |  | 271 | my $in        = $params{-in}; | 
| 543 | 16 |  |  |  |  | 95 | my $in_fname  = $params{-in_fname}; | 
| 544 | 16 |  |  |  |  | 89 | my $out       = $params{-out}; | 
| 545 | 16 |  |  |  |  | 60 | my $out_fname = $params{-out_fname}; | 
| 546 | 16 |  |  |  |  | 62 | my $u         = $params{-uri}; | 
| 547 | 16 |  |  |  |  | 67 | my $path      = $params{-path_info}; | 
| 548 | 16 |  |  |  |  | 79 | my $input     = $params{-input}; | 
| 549 |  |  |  |  |  |  |  | 
| 550 |  |  |  |  |  |  | # | 
| 551 |  |  |  |  |  |  | # Connect file descriptors. | 
| 552 |  |  |  |  |  |  | # | 
| 553 |  |  |  |  |  |  |  | 
| 554 | 16 | 50 |  |  |  | 304 | if ( !WINDOWS ) { | 
| 555 | 16 | 100 |  |  |  | 206 | if (defined $in) | 
| 556 |  |  |  |  |  |  | { | 
| 557 | 1 | 50 |  |  |  | 58 | open(STDIN, '<&=' . fileno($in)) || die "can't redirect STDIN: $!"; | 
| 558 |  |  |  |  |  |  | } | 
| 559 |  |  |  |  |  |  | else | 
| 560 |  |  |  |  |  |  | { | 
| 561 | 15 |  |  |  |  | 1057 | my $devnull = File::Spec->devnull; | 
| 562 | 15 | 50 |  |  |  | 1790 | open(STDIN, $devnull) || die "can't open $devnull: $!"; | 
| 563 |  |  |  |  |  |  | } | 
| 564 | 16 | 50 |  |  |  | 597 | open(STDOUT, '>&=' . fileno($out)) || die "can't redirect STDOUT: $!"; | 
| 565 |  |  |  |  |  |  | } | 
| 566 |  |  |  |  |  |  |  | 
| 567 |  |  |  |  |  |  | # | 
| 568 |  |  |  |  |  |  | # Setup default CGI environment. | 
| 569 |  |  |  |  |  |  | # | 
| 570 |  |  |  |  |  |  |  | 
| 571 | 16 |  |  |  |  | 55 | while (my ($key, $value) = each %{$this->cgi_env}) | 
|  | 210 |  |  |  |  | 494 |  | 
| 572 |  |  |  |  |  |  | { | 
| 573 | 194 |  |  |  |  | 1222 | $ENV{$key} = $value; | 
| 574 |  |  |  |  |  |  | } | 
| 575 |  |  |  |  |  |  |  | 
| 576 |  |  |  |  |  |  | # | 
| 577 |  |  |  |  |  |  | # Where there is a script input, setup CONTENT_* variables. | 
| 578 |  |  |  |  |  |  | # If there's no input, delete CONTENT_* variables. | 
| 579 |  |  |  |  |  |  | # | 
| 580 |  |  |  |  |  |  |  | 
| 581 | 16 | 100 |  |  |  | 148 | if (defined $input) | 
| 582 |  |  |  |  |  |  | { | 
| 583 | 1 |  |  |  |  | 16 | $ENV{CONTENT_TYPE}   = $input->mime_type; | 
| 584 | 1 |  |  |  |  | 43 | $ENV{CONTENT_LENGTH} = $input->length; | 
| 585 |  |  |  |  |  |  | } | 
| 586 |  |  |  |  |  |  | else | 
| 587 |  |  |  |  |  |  | { | 
| 588 | 15 |  |  |  |  | 157 | delete $ENV{CONTENT_TYPE}; | 
| 589 | 15 |  |  |  |  | 110 | delete $ENV{CONTENT_LENGTH}; | 
| 590 |  |  |  |  |  |  | } | 
| 591 |  |  |  |  |  |  |  | 
| 592 |  |  |  |  |  |  | # | 
| 593 |  |  |  |  |  |  | # Supersede whatever they may have set for the following variables, | 
| 594 |  |  |  |  |  |  | # which are very request-specific: | 
| 595 |  |  |  |  |  |  | # | 
| 596 |  |  |  |  |  |  |  | 
| 597 | 16 | 100 |  |  |  | 191 | $ENV{REQUEST_METHOD}  = defined $input ? "POST" : "GET"; | 
| 598 | 16 |  |  |  |  | 87 | $ENV{PATH_INFO}       = $path; | 
| 599 | 16 |  |  |  |  | 87 | $ENV{SCRIPT_NAME}     = $name; | 
| 600 | 16 |  |  |  |  | 59 | $ENV{SCRIPT_FILENAME} = $script; | 
| 601 | 16 |  |  |  |  | 550 | $ENV{HTTP_HOST}       = $u->host_port; | 
| 602 |  |  |  |  |  |  |  | 
| 603 | 16 | 50 |  |  |  | 1944 | if (length $path) | 
| 604 |  |  |  |  |  |  | { | 
| 605 | 16 |  |  |  |  | 102 | $ENV{PATH_TRANSLATED} = $this->doc_dir . $path; | 
| 606 |  |  |  |  |  |  | } | 
| 607 |  |  |  |  |  |  | else | 
| 608 |  |  |  |  |  |  | { | 
| 609 | 0 |  |  |  |  | 0 | delete $ENV{PATH_TRANSLATED}; | 
| 610 |  |  |  |  |  |  | } | 
| 611 |  |  |  |  |  |  |  | 
| 612 | 16 | 100 |  |  |  | 68 | if (defined $user) | 
| 613 |  |  |  |  |  |  | { | 
| 614 | 1 |  |  |  |  | 5 | $ENV{REMOTE_USER} = $user; | 
| 615 |  |  |  |  |  |  | } | 
| 616 |  |  |  |  |  |  | else | 
| 617 |  |  |  |  |  |  | { | 
| 618 | 15 |  |  |  |  | 68 | delete $ENV{REMOTE_USER}; | 
| 619 | 15 |  |  |  |  | 58 | delete $ENV{AUTH_TYPE}; | 
| 620 |  |  |  |  |  |  | } | 
| 621 |  |  |  |  |  |  |  | 
| 622 | 16 | 100 |  |  |  | 185 | if (defined $u->query) | 
| 623 |  |  |  |  |  |  | { | 
| 624 | 12 |  |  |  |  | 269 | $ENV{QUERY_STRING} = $u->query; | 
| 625 |  |  |  |  |  |  | } | 
| 626 |  |  |  |  |  |  | else | 
| 627 |  |  |  |  |  |  | { | 
| 628 | 4 |  |  |  |  | 138 | delete $ENV{QUERY_STRING}; | 
| 629 |  |  |  |  |  |  | } | 
| 630 |  |  |  |  |  |  |  | 
| 631 |  |  |  |  |  |  | # | 
| 632 |  |  |  |  |  |  | # This is a way of letting Perl test scripts to run under | 
| 633 |  |  |  |  |  |  | # the same Perl version that CGI::Test is running with | 
| 634 |  |  |  |  |  |  | # | 
| 635 |  |  |  |  |  |  |  | 
| 636 | 16 |  |  |  |  | 229 | $ENV{PERL} = $^X; | 
| 637 |  |  |  |  |  |  |  | 
| 638 |  |  |  |  |  |  | # | 
| 639 |  |  |  |  |  |  | # Make sure the script sees the same @INC as we do currently. | 
| 640 |  |  |  |  |  |  | # This is very important when running a regression test suite, to | 
| 641 |  |  |  |  |  |  | # make sure any CGI script using the module we're testing will see | 
| 642 |  |  |  |  |  |  | # the files from the build directory. | 
| 643 |  |  |  |  |  |  | # | 
| 644 |  |  |  |  |  |  | # Since we're about to chdir() to the cgi-bin directory, we must anchor | 
| 645 |  |  |  |  |  |  | # any relative path to the current working directory. | 
| 646 |  |  |  |  |  |  | # | 
| 647 | 16 | 50 |  |  |  | 154 | my $path_sep = WINDOWS ? ';' : ':'; | 
| 648 |  |  |  |  |  |  |  | 
| 649 | 16 | 50 |  |  |  | 613 | $ENV{PERL5LIB} = join($path_sep, map {-e $_ ? abs_path($_) : $_} @INC); | 
|  | 167 |  |  |  |  | 8919 |  | 
| 650 |  |  |  |  |  |  |  | 
| 651 |  |  |  |  |  |  | # Also make sure that temp directory is available for the script, | 
| 652 |  |  |  |  |  |  | # else older CGI.pm may choke and default to some not-quite-sane | 
| 653 |  |  |  |  |  |  | # values that do not work in Windows | 
| 654 |  |  |  |  |  |  |  | 
| 655 | 16 |  |  |  |  | 96 | $ENV{TMPDIR} = $this->tmp_dir; | 
| 656 |  |  |  |  |  |  |  | 
| 657 |  |  |  |  |  |  | # | 
| 658 |  |  |  |  |  |  | # Now run the script, changing the current directory to the location | 
| 659 |  |  |  |  |  |  | # of the script, as a web server would. | 
| 660 |  |  |  |  |  |  | # | 
| 661 |  |  |  |  |  |  |  | 
| 662 | 16 |  |  |  |  | 1918 | my $directory = dirname($script); | 
| 663 | 16 |  |  |  |  | 377 | my $basename  = basename($script); | 
| 664 |  |  |  |  |  |  |  | 
| 665 | 16 | 50 |  |  |  | 286 | chdir $directory or die "can't cd to $directory: $!"; | 
| 666 |  |  |  |  |  |  |  | 
| 667 | 16 | 50 |  |  |  | 103 | if ( WINDOWS ) { | 
| 668 | 0 | 0 |  |  |  | 0 | my $cmd_line = $input ? "$basename < ${in_fname} > ${out_fname}" | 
| 669 |  |  |  |  |  |  | :          "$basename < NUL >${out_fname}" | 
| 670 |  |  |  |  |  |  | ; | 
| 671 |  |  |  |  |  |  |  | 
| 672 | 0 |  |  |  |  | 0 | exec $cmd_line; | 
| 673 |  |  |  |  |  |  | } | 
| 674 |  |  |  |  |  |  | else { | 
| 675 | 16 |  |  |  |  | 0 | exec "./$basename"; | 
| 676 |  |  |  |  |  |  | } | 
| 677 |  |  |  |  |  |  |  | 
| 678 | 0 |  |  |  |  | 0 | die "could not exec $script: $!"; | 
| 679 |  |  |  |  |  |  | } | 
| 680 |  |  |  |  |  |  |  | 
| 681 |  |  |  |  |  |  | ###################################################################### | 
| 682 |  |  |  |  |  |  | # | 
| 683 |  |  |  |  |  |  | # ->_parse_header | 
| 684 |  |  |  |  |  |  | # | 
| 685 |  |  |  |  |  |  | # Look for a set of leading HTTP headers in the file, and insert them | 
| 686 |  |  |  |  |  |  | # into a hash table (we don't expect duplicates). | 
| 687 |  |  |  |  |  |  | # | 
| 688 |  |  |  |  |  |  | # Returns ref to hash containing the headers. | 
| 689 |  |  |  |  |  |  | # | 
| 690 |  |  |  |  |  |  | ###################################################################### | 
| 691 |  |  |  |  |  |  | sub _parse_header | 
| 692 |  |  |  |  |  |  | { | 
| 693 | 28 |  |  | 28 |  | 96 | my $this = shift; | 
| 694 | 28 |  |  |  |  | 126 | my ($file) = @_; | 
| 695 | 28 |  |  |  |  | 92 | my %header; | 
| 696 | 28 |  |  |  |  | 216 | local *FILE; | 
| 697 | 28 | 50 |  |  |  | 1987 | open(FILE, $file) || warn "can't open $file: $!"; | 
| 698 | 28 |  |  |  |  | 168 | local $_; | 
| 699 | 28 |  |  |  |  | 59 | my $field; | 
| 700 |  |  |  |  |  |  |  | 
| 701 | 28 |  |  |  |  | 772 | while () | 
| 702 |  |  |  |  |  |  | { | 
| 703 | 72 | 100 | 66 |  |  | 619 | last if /^\015?\012$/ || /^\015\012$/; | 
| 704 | 44 |  |  |  |  | 420 | s/\015?\012$//; | 
| 705 | 44 | 50 |  |  |  | 564 | if (s/^\s+/ /) | 
|  |  | 50 |  |  |  |  |  | 
| 706 |  |  |  |  |  |  | { | 
| 707 | 0 | 0 |  |  |  | 0 | last if $field eq '';    # Cannot be a header | 
| 708 | 0 | 0 |  |  |  | 0 | $header{$field} .= $_ if $field ne ''; | 
| 709 |  |  |  |  |  |  | } | 
| 710 |  |  |  |  |  |  | elsif (($field, my $value) = /^([\w-]+)\s*:\s*(.*)/) | 
| 711 |  |  |  |  |  |  | { | 
| 712 | 44 |  |  |  |  | 493 | $field =~ s/(\w+)/\u\L$1/g;    # Normalize spelling | 
| 713 | 44 | 50 |  |  |  | 148 | if (exists $header{$field}) | 
| 714 |  |  |  |  |  |  | { | 
| 715 | 0 |  |  |  |  | 0 | warn "duplicate $field header in $file"; | 
| 716 | 0 |  |  |  |  | 0 | $header{$field} .= " "; | 
| 717 |  |  |  |  |  |  | } | 
| 718 | 44 |  |  |  |  | 390 | $header{$field} .= $value; | 
| 719 |  |  |  |  |  |  | } | 
| 720 |  |  |  |  |  |  | else | 
| 721 |  |  |  |  |  |  | { | 
| 722 | 0 |  |  |  |  | 0 | warn "mangled header in $file"; | 
| 723 | 0 |  |  |  |  | 0 | %header = ();                  # Discard what we read sofar | 
| 724 | 0 |  |  |  |  | 0 | last; | 
| 725 |  |  |  |  |  |  | } | 
| 726 |  |  |  |  |  |  | } | 
| 727 | 28 |  |  |  |  | 249 | close FILE; | 
| 728 | 28 |  |  |  |  | 225 | return \%header; | 
| 729 |  |  |  |  |  |  | } | 
| 730 |  |  |  |  |  |  |  | 
| 731 |  |  |  |  |  |  | 1; | 
| 732 |  |  |  |  |  |  |  | 
| 733 |  |  |  |  |  |  | =head1 NAME | 
| 734 |  |  |  |  |  |  |  | 
| 735 |  |  |  |  |  |  | CGI::Test - CGI regression test framework | 
| 736 |  |  |  |  |  |  |  | 
| 737 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 738 |  |  |  |  |  |  |  | 
| 739 |  |  |  |  |  |  | # In some t/script.t regression test, for instance | 
| 740 |  |  |  |  |  |  | use CGI::Test; | 
| 741 |  |  |  |  |  |  | use Test::More tests => 7; | 
| 742 |  |  |  |  |  |  |  | 
| 743 |  |  |  |  |  |  | my $ct = CGI::Test->new( | 
| 744 |  |  |  |  |  |  | -base_url   => "http://some.server:1234/cgi-bin", | 
| 745 |  |  |  |  |  |  | -cgi_dir    => "/path/to/cgi-bin", | 
| 746 |  |  |  |  |  |  | ); | 
| 747 |  |  |  |  |  |  |  | 
| 748 |  |  |  |  |  |  | my $page = $ct->GET("http://some.server:1234/cgi-bin/script?arg=1"); | 
| 749 |  |  |  |  |  |  | like $page->content_type, qr|text/html\b|, "Content type"; | 
| 750 |  |  |  |  |  |  |  | 
| 751 |  |  |  |  |  |  | my $form = $page->forms->[0]; | 
| 752 |  |  |  |  |  |  | is $form->action, "/cgi-bin/some_target", "Form action URI"; | 
| 753 |  |  |  |  |  |  |  | 
| 754 |  |  |  |  |  |  | my $menu = $form->menu_by_name("months"); | 
| 755 |  |  |  |  |  |  | ok $menu->is_selected("January"), "January selected"; | 
| 756 |  |  |  |  |  |  | ok !$menu->is_selected("March"),  "March not selected"; | 
| 757 |  |  |  |  |  |  | ok $menu->multiple,               "Menu is multi-choice"; | 
| 758 |  |  |  |  |  |  |  | 
| 759 |  |  |  |  |  |  | my $send = $form->submit_by_name("send_form"); | 
| 760 |  |  |  |  |  |  | ok defined $send, "Send form defined"; | 
| 761 |  |  |  |  |  |  |  | 
| 762 |  |  |  |  |  |  | # | 
| 763 |  |  |  |  |  |  | # Now interact with the CGI | 
| 764 |  |  |  |  |  |  | # | 
| 765 |  |  |  |  |  |  |  | 
| 766 |  |  |  |  |  |  | $menu->select("March");        # "click" on the March label | 
| 767 |  |  |  |  |  |  | my $answer = $send->press;     # "click" on the send button | 
| 768 |  |  |  |  |  |  |  | 
| 769 |  |  |  |  |  |  | # and make sure we don't get an HTTP error | 
| 770 |  |  |  |  |  |  | ok $answer->is_ok, "Answer response"; | 
| 771 |  |  |  |  |  |  |  | 
| 772 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 773 |  |  |  |  |  |  |  | 
| 774 |  |  |  |  |  |  | The C module provides a CGI regression test framework which | 
| 775 |  |  |  |  |  |  | allows you to run your CGI programs offline, i.e. outside a web server, | 
| 776 |  |  |  |  |  |  | and interact with them programmatically, without the need to type data | 
| 777 |  |  |  |  |  |  | and click from a web browser. | 
| 778 |  |  |  |  |  |  |  | 
| 779 |  |  |  |  |  |  | If you're using the C module, you may be familiar with its offline | 
| 780 |  |  |  |  |  |  | testing mode.  However, this mode is appropriate for simple things, and | 
| 781 |  |  |  |  |  |  | there is no support for conducting a full session with a stateful script. | 
| 782 |  |  |  |  |  |  | C fills this gap by providing the necessary infrastructure to | 
| 783 |  |  |  |  |  |  | run CGI scripts, then parse the output to construct objects that can be | 
| 784 |  |  |  |  |  |  | queried, and on which you can interact to "play" with the script's control | 
| 785 |  |  |  |  |  |  | widgets, finally submitting data back.  And so on... | 
| 786 |  |  |  |  |  |  |  | 
| 787 |  |  |  |  |  |  | Note that the CGI scripts you can test with C need not be | 
| 788 |  |  |  |  |  |  | implemented in Perl at all.  As far as this framework is concerned, CGI | 
| 789 |  |  |  |  |  |  | scripts are executables that are run on a CGI-like environment and which | 
| 790 |  |  |  |  |  |  | produce an output. | 
| 791 |  |  |  |  |  |  |  | 
| 792 |  |  |  |  |  |  | To use the C framework, you need to configure a C | 
| 793 |  |  |  |  |  |  | object to act like a web server, by providing the URL base where | 
| 794 |  |  |  |  |  |  | CGI scripts lie on this pseudo-server, and which physical directory | 
| 795 |  |  |  |  |  |  | corresponds to that URL base. | 
| 796 |  |  |  |  |  |  |  | 
| 797 |  |  |  |  |  |  | From then on, you may issue GET and POST requests giving an URL, and | 
| 798 |  |  |  |  |  |  | the pseudo-server returns a C object representing the | 
| 799 |  |  |  |  |  |  | outcome of the request.  This page may be an error, plain text, some | 
| 800 |  |  |  |  |  |  | binary data, or an HTML page (see L for details). | 
| 801 |  |  |  |  |  |  |  | 
| 802 |  |  |  |  |  |  | The latter (an HTML page) can contain one or more CGI forms (identified | 
| 803 |  |  |  |  |  |  | by CFORME> tags), which are described by instances of | 
| 804 |  |  |  |  |  |  | C objects (see L for details). | 
| 805 |  |  |  |  |  |  |  | 
| 806 |  |  |  |  |  |  | Forms can be queried to see whether they contain a particular type | 
| 807 |  |  |  |  |  |  | of widget (menu, text area, button, etc...), of a particular name | 
| 808 |  |  |  |  |  |  | (that's the CGI parameter name).  Once found, one may interact with | 
| 809 |  |  |  |  |  |  | a widget as the user would from a browser.  Widgets are described by | 
| 810 |  |  |  |  |  |  | polymorphic objects which conform to the C type. | 
| 811 |  |  |  |  |  |  | The specific interaction that is offered depends on the dynamic type of | 
| 812 |  |  |  |  |  |  | the object (see L for details). | 
| 813 |  |  |  |  |  |  |  | 
| 814 |  |  |  |  |  |  | An interaction with a form ends by a submission of the form data to the | 
| 815 |  |  |  |  |  |  | server, and getting a reply back.  This is done by pressing a submit button, | 
| 816 |  |  |  |  |  |  | and the press() routine returns a new page.  Naturally, no server is | 
| 817 |  |  |  |  |  |  | contacted at all within the C framework, and the CGI script is | 
| 818 |  |  |  |  |  |  | ran through a proper call to one of the GET/POST method on the | 
| 819 |  |  |  |  |  |  | C object. | 
| 820 |  |  |  |  |  |  |  | 
| 821 |  |  |  |  |  |  | =head1 INTERFACE | 
| 822 |  |  |  |  |  |  |  | 
| 823 |  |  |  |  |  |  | =head2 Creation Interface | 
| 824 |  |  |  |  |  |  |  | 
| 825 |  |  |  |  |  |  | The creation routine C takes the following mandatory parameters: | 
| 826 |  |  |  |  |  |  |  | 
| 827 |  |  |  |  |  |  | =over 4 | 
| 828 |  |  |  |  |  |  |  | 
| 829 |  |  |  |  |  |  | =item C<-base_url> => I | 
| 830 |  |  |  |  |  |  |  | 
| 831 |  |  |  |  |  |  | Defines the URL domain which is handled by C. | 
| 832 |  |  |  |  |  |  | This is the URL of the C directory. | 
| 833 |  |  |  |  |  |  |  | 
| 834 |  |  |  |  |  |  | Note that there is no need to have something actually running on the | 
| 835 |  |  |  |  |  |  | specified host or port, and the server name can be any host name, | 
| 836 |  |  |  |  |  |  | whether it exists or not.  For instance, if you say: | 
| 837 |  |  |  |  |  |  |  | 
| 838 |  |  |  |  |  |  | -base_url => "http://foo.example.com:70/cgi-bin" | 
| 839 |  |  |  |  |  |  |  | 
| 840 |  |  |  |  |  |  | you simply declare that the C object will know how to handle | 
| 841 |  |  |  |  |  |  | a GET request for, say: | 
| 842 |  |  |  |  |  |  |  | 
| 843 |  |  |  |  |  |  | http://foo.example.com:70/cgi-bin/script | 
| 844 |  |  |  |  |  |  |  | 
| 845 |  |  |  |  |  |  | and it will do so I, without contacting C | 
| 846 |  |  |  |  |  |  | on port 70... | 
| 847 |  |  |  |  |  |  |  | 
| 848 |  |  |  |  |  |  | =item C<-cgi_dir> => I | 
| 849 |  |  |  |  |  |  |  | 
| 850 |  |  |  |  |  |  | Defines the physical path corresponding to the C directory defined | 
| 851 |  |  |  |  |  |  | by the C<-base_url> parameter. | 
| 852 |  |  |  |  |  |  |  | 
| 853 |  |  |  |  |  |  | For instance, given the settings: | 
| 854 |  |  |  |  |  |  |  | 
| 855 |  |  |  |  |  |  | -base_url => "http://foo.example.com:70/cgi-bin", | 
| 856 |  |  |  |  |  |  | -cgi_dir  => "/home/ram/cgi/test" | 
| 857 |  |  |  |  |  |  |  | 
| 858 |  |  |  |  |  |  | then requesting | 
| 859 |  |  |  |  |  |  |  | 
| 860 |  |  |  |  |  |  | http://foo.example.com:70/cgi-bin/script | 
| 861 |  |  |  |  |  |  |  | 
| 862 |  |  |  |  |  |  | will actually run | 
| 863 |  |  |  |  |  |  |  | 
| 864 |  |  |  |  |  |  | /home/ram/cgi/test/script | 
| 865 |  |  |  |  |  |  |  | 
| 866 |  |  |  |  |  |  | Those things are really easier to understand via examples than via | 
| 867 |  |  |  |  |  |  | formal descriptions, aren't they? | 
| 868 |  |  |  |  |  |  |  | 
| 869 |  |  |  |  |  |  | =back | 
| 870 |  |  |  |  |  |  |  | 
| 871 |  |  |  |  |  |  | The following optional arguments may also be provided: | 
| 872 |  |  |  |  |  |  |  | 
| 873 |  |  |  |  |  |  | =over 4 | 
| 874 |  |  |  |  |  |  |  | 
| 875 |  |  |  |  |  |  | =item C<-cgi_env> => I | 
| 876 |  |  |  |  |  |  |  | 
| 877 |  |  |  |  |  |  | Defines additional environment variables that must be set, or changes | 
| 878 |  |  |  |  |  |  | hardwirted defaults.  Some variables like C really depend | 
| 879 |  |  |  |  |  |  | on the request and will be dynamically computed by C. | 
| 880 |  |  |  |  |  |  |  | 
| 881 |  |  |  |  |  |  | For instance: | 
| 882 |  |  |  |  |  |  |  | 
| 883 |  |  |  |  |  |  | -cgi_env => { | 
| 884 |  |  |  |  |  |  | HTTP_USER_AGENT     => "Mozilla/4.76", | 
| 885 |  |  |  |  |  |  | AUTH_TYPE           => "Digest", | 
| 886 |  |  |  |  |  |  | } | 
| 887 |  |  |  |  |  |  |  | 
| 888 |  |  |  |  |  |  | See L for more details on which environment | 
| 889 |  |  |  |  |  |  | variables are defined, and which may be superseded. | 
| 890 |  |  |  |  |  |  |  | 
| 891 |  |  |  |  |  |  | =item C<-doc_dir> => I | 
| 892 |  |  |  |  |  |  |  | 
| 893 |  |  |  |  |  |  | This defines the root directory of the HTTP server, for path translation. | 
| 894 |  |  |  |  |  |  | It defaults to C. | 
| 895 |  |  |  |  |  |  |  | 
| 896 |  |  |  |  |  |  | B: C only serves CGI scripts for now, so this setting | 
| 897 |  |  |  |  |  |  | is not terribly useful, unless you care about C. | 
| 898 |  |  |  |  |  |  |  | 
| 899 |  |  |  |  |  |  | =item C<-tmp_dir> => I | 
| 900 |  |  |  |  |  |  |  | 
| 901 |  |  |  |  |  |  | The temporary directory to use for internal files created while processing | 
| 902 |  |  |  |  |  |  | requests.  Defaults to the value of the environment variable C, | 
| 903 |  |  |  |  |  |  | or C if it is not set. | 
| 904 |  |  |  |  |  |  |  | 
| 905 |  |  |  |  |  |  | =back | 
| 906 |  |  |  |  |  |  |  | 
| 907 |  |  |  |  |  |  | =head2 Object Interface | 
| 908 |  |  |  |  |  |  |  | 
| 909 |  |  |  |  |  |  | The following methods, listed in alphabetical order, are available: | 
| 910 |  |  |  |  |  |  |  | 
| 911 |  |  |  |  |  |  | =over 4 | 
| 912 |  |  |  |  |  |  |  | 
| 913 |  |  |  |  |  |  | =item C I [, I] | 
| 914 |  |  |  |  |  |  |  | 
| 915 |  |  |  |  |  |  | Issues an HTTP GET request of the specified URL, given as the string | 
| 916 |  |  |  |  |  |  | I.  It must be in the http scheme, and must lie within the | 
| 917 |  |  |  |  |  |  | configured CGI space (i.e. under the base URL given at creation time | 
| 918 |  |  |  |  |  |  | via C<-base_url>). | 
| 919 |  |  |  |  |  |  |  | 
| 920 |  |  |  |  |  |  | Optionally, you may specify the name of an authenticated user as the | 
| 921 |  |  |  |  |  |  | I string. C will simply setup the CGI environment | 
| 922 |  |  |  |  |  |  | variable C accordingly.  Since we're in a testing framework, | 
| 923 |  |  |  |  |  |  | you can pretend to be anyone you like.  See L | 
| 924 |  |  |  |  |  |  | for more information on environment variables, and in particular | 
| 925 |  |  |  |  |  |  | C. | 
| 926 |  |  |  |  |  |  |  | 
| 927 |  |  |  |  |  |  | C returns a C polymorphic object, i.e. an object whose | 
| 928 |  |  |  |  |  |  | dynamic type is an heir of C.  See L for | 
| 929 |  |  |  |  |  |  | more information on this class hierarchy. | 
| 930 |  |  |  |  |  |  |  | 
| 931 |  |  |  |  |  |  | =item C I, I [, I] | 
| 932 |  |  |  |  |  |  |  | 
| 933 |  |  |  |  |  |  | Issues an HTTP POST request of the specified URL.  See C above for | 
| 934 |  |  |  |  |  |  | a discussion on I and I, which applies to C | 
| 935 |  |  |  |  |  |  | as well. | 
| 936 |  |  |  |  |  |  |  | 
| 937 |  |  |  |  |  |  | The I parameter must be a C object. | 
| 938 |  |  |  |  |  |  | It specifies the CGI parameters to be sent to the script.  Users normally | 
| 939 |  |  |  |  |  |  | don't issue POST requests manually: they are the result of submits on | 
| 940 |  |  |  |  |  |  | forms, which are obtained via an initial GET.  Nonetheless, you can | 
| 941 |  |  |  |  |  |  | create your own input easily and issue a "faked" POST request, to see | 
| 942 |  |  |  |  |  |  | how your script might react to inconsistent (and probably malicious) | 
| 943 |  |  |  |  |  |  | input for instance.  See L to learn how to construct | 
| 944 |  |  |  |  |  |  | suitable input. | 
| 945 |  |  |  |  |  |  |  | 
| 946 |  |  |  |  |  |  | C returns a C polymorphic object, like C does. | 
| 947 |  |  |  |  |  |  |  | 
| 948 |  |  |  |  |  |  | =item C | 
| 949 |  |  |  |  |  |  |  | 
| 950 |  |  |  |  |  |  | The base path in the URL space of the base URL configured at creation time. | 
| 951 |  |  |  |  |  |  | It's the URL with the scheme, host and port information removed. | 
| 952 |  |  |  |  |  |  |  | 
| 953 |  |  |  |  |  |  | =item C | 
| 954 |  |  |  |  |  |  |  | 
| 955 |  |  |  |  |  |  | The configured CGI root directory where scripts to be run are held. | 
| 956 |  |  |  |  |  |  |  | 
| 957 |  |  |  |  |  |  | =item C | 
| 958 |  |  |  |  |  |  |  | 
| 959 |  |  |  |  |  |  | The configured document root directory. | 
| 960 |  |  |  |  |  |  |  | 
| 961 |  |  |  |  |  |  | =item C | 
| 962 |  |  |  |  |  |  |  | 
| 963 |  |  |  |  |  |  | The host and port of the base URL you configured at creation time. | 
| 964 |  |  |  |  |  |  |  | 
| 965 |  |  |  |  |  |  | =item C I | 
| 966 |  |  |  |  |  |  |  | 
| 967 |  |  |  |  |  |  | Splits an URI object into server (host and port), path and query components. | 
| 968 |  |  |  |  |  |  | The path is simplified using UNIX semantics, i.e. C is ignored and | 
| 969 |  |  |  |  |  |  | stripped, and C is resolved by forgetting the path component that | 
| 970 |  |  |  |  |  |  | immediately precedes it (no attempt is made to make sure the translated path | 
| 971 |  |  |  |  |  |  | was indeed pointing to an existing directory: simplification happens in the | 
| 972 |  |  |  |  |  |  | path space). | 
| 973 |  |  |  |  |  |  |  | 
| 974 |  |  |  |  |  |  | Returns the list (host, path, query). | 
| 975 |  |  |  |  |  |  |  | 
| 976 |  |  |  |  |  |  | =item C | 
| 977 |  |  |  |  |  |  |  | 
| 978 |  |  |  |  |  |  | The temporary directory that is being used. | 
| 979 |  |  |  |  |  |  |  | 
| 980 |  |  |  |  |  |  | =item C | 
| 981 |  |  |  |  |  |  |  | 
| 982 |  |  |  |  |  |  | Returns hashref with parsed HTTP headers received from CGI script. | 
| 983 |  |  |  |  |  |  |  | 
| 984 |  |  |  |  |  |  | =back | 
| 985 |  |  |  |  |  |  |  | 
| 986 |  |  |  |  |  |  | =head1 CGI ENVIRONMENT VARIABLES | 
| 987 |  |  |  |  |  |  |  | 
| 988 |  |  |  |  |  |  | The CGI protocol defines a set of environment variables which are to be set | 
| 989 |  |  |  |  |  |  | by the web server before invoking the script.  The environment created by | 
| 990 |  |  |  |  |  |  | C conforms to the CGI/1.1 specifications. | 
| 991 |  |  |  |  |  |  |  | 
| 992 |  |  |  |  |  |  | Here is a list of all the known variables.  Some of those are marked | 
| 993 |  |  |  |  |  |  | I.  It means you may choose to set them via the C<-cgi_env> | 
| 994 |  |  |  |  |  |  | switch of the C routine, but your settings will have no effect and | 
| 995 |  |  |  |  |  |  | C will always compute a suitable value. | 
| 996 |  |  |  |  |  |  |  | 
| 997 |  |  |  |  |  |  | Variables are listed in alphabetical order: | 
| 998 |  |  |  |  |  |  |  | 
| 999 |  |  |  |  |  |  | =over 4 | 
| 1000 |  |  |  |  |  |  |  | 
| 1001 |  |  |  |  |  |  | =item C | 
| 1002 |  |  |  |  |  |  |  | 
| 1003 |  |  |  |  |  |  | The authentication scheme used to authenticate the user given by C. | 
| 1004 |  |  |  |  |  |  | This variable is not present in the environment if there was no user specified | 
| 1005 |  |  |  |  |  |  | in the GET/POST requests. | 
| 1006 |  |  |  |  |  |  |  | 
| 1007 |  |  |  |  |  |  | By default, it is set to "Basic" when present. | 
| 1008 |  |  |  |  |  |  |  | 
| 1009 |  |  |  |  |  |  | =item C | 
| 1010 |  |  |  |  |  |  |  | 
| 1011 |  |  |  |  |  |  | Read-only variable, giving the length of data to be read on STDIN by POST | 
| 1012 |  |  |  |  |  |  | requests (as told by C).  If is not present for GET requests. | 
| 1013 |  |  |  |  |  |  |  | 
| 1014 |  |  |  |  |  |  | =item C | 
| 1015 |  |  |  |  |  |  |  | 
| 1016 |  |  |  |  |  |  | Read-only variable, giving the MIME type of data to be read on STDIN by POST | 
| 1017 |  |  |  |  |  |  | requests (as told by C).  If is not present for GET requests. | 
| 1018 |  |  |  |  |  |  |  | 
| 1019 |  |  |  |  |  |  | =item C | 
| 1020 |  |  |  |  |  |  |  | 
| 1021 |  |  |  |  |  |  | The Common Gateway Interface (CGI) version specification. | 
| 1022 |  |  |  |  |  |  | Defaults to "CGI/1.1". | 
| 1023 |  |  |  |  |  |  |  | 
| 1024 |  |  |  |  |  |  | =item C | 
| 1025 |  |  |  |  |  |  |  | 
| 1026 |  |  |  |  |  |  | The set of Content-Type that are said to be accepted by the client issuing | 
| 1027 |  |  |  |  |  |  | the HTTP request.  Since there is no browser making any request here, the | 
| 1028 |  |  |  |  |  |  | default is set to "*/*". | 
| 1029 |  |  |  |  |  |  |  | 
| 1030 |  |  |  |  |  |  | It is up to your script to honour the value of this variable if it wishes to | 
| 1031 |  |  |  |  |  |  | be nice with the client. | 
| 1032 |  |  |  |  |  |  |  | 
| 1033 |  |  |  |  |  |  | =item C | 
| 1034 |  |  |  |  |  |  |  | 
| 1035 |  |  |  |  |  |  | The charset that is said to be accepted by the client issuing the HTTP | 
| 1036 |  |  |  |  |  |  | request.  Since there is no browser making any request here, the | 
| 1037 |  |  |  |  |  |  | default is set to "iso-8859-1". | 
| 1038 |  |  |  |  |  |  |  | 
| 1039 |  |  |  |  |  |  | =item C | 
| 1040 |  |  |  |  |  |  |  | 
| 1041 |  |  |  |  |  |  | Whether the connection should be kept alive by the server or closed after | 
| 1042 |  |  |  |  |  |  | this request.  Defaults to "Close", but since there's no connection and | 
| 1043 |  |  |  |  |  |  | no real client... | 
| 1044 |  |  |  |  |  |  |  | 
| 1045 |  |  |  |  |  |  | =item C | 
| 1046 |  |  |  |  |  |  |  | 
| 1047 |  |  |  |  |  |  | This is the host processing the HTTP request. | 
| 1048 |  |  |  |  |  |  | It is a read-only variable, set to the hostname and port parts of the | 
| 1049 |  |  |  |  |  |  | requested URL. | 
| 1050 |  |  |  |  |  |  |  | 
| 1051 |  |  |  |  |  |  | =item C | 
| 1052 |  |  |  |  |  |  |  | 
| 1053 |  |  |  |  |  |  | The user agent tag string.  This can be used by scripts to emit code that | 
| 1054 |  |  |  |  |  |  | can be understood by the client, and is also further abused to derive the | 
| 1055 |  |  |  |  |  |  | OS type where the user agent runs. | 
| 1056 |  |  |  |  |  |  |  | 
| 1057 |  |  |  |  |  |  | In order to be as neutral as possible, it is set to "CGI::Test" by default. | 
| 1058 |  |  |  |  |  |  |  | 
| 1059 |  |  |  |  |  |  | =item C | 
| 1060 |  |  |  |  |  |  |  | 
| 1061 |  |  |  |  |  |  | Read-only variable set to the extra path information part of the requested URL. | 
| 1062 |  |  |  |  |  |  | Always present, even if empty. | 
| 1063 |  |  |  |  |  |  |  | 
| 1064 |  |  |  |  |  |  | =item C | 
| 1065 |  |  |  |  |  |  |  | 
| 1066 |  |  |  |  |  |  | This read-only variable is only present when there is a non-empty C | 
| 1067 |  |  |  |  |  |  | variable.  It is simply set to the value of C with the document | 
| 1068 |  |  |  |  |  |  | rootdir path prepended to it (the value of the C<-doc_dir> creation argument). | 
| 1069 |  |  |  |  |  |  |  | 
| 1070 |  |  |  |  |  |  | =item C | 
| 1071 |  |  |  |  |  |  |  | 
| 1072 |  |  |  |  |  |  | This very important read-only variable is the query string present in the | 
| 1073 |  |  |  |  |  |  | requested URL.  Note that it may very well be set even for a POST request. | 
| 1074 |  |  |  |  |  |  |  | 
| 1075 |  |  |  |  |  |  | =item C | 
| 1076 |  |  |  |  |  |  |  | 
| 1077 |  |  |  |  |  |  | The IP address of the client making the requst.  Can be used to implement | 
| 1078 |  |  |  |  |  |  | an access policy from within the script.  Here, given that there's no real | 
| 1079 |  |  |  |  |  |  | client, the default is set to "127.0.0.1", which is the IP of the local | 
| 1080 |  |  |  |  |  |  | loopback interface. | 
| 1081 |  |  |  |  |  |  |  | 
| 1082 |  |  |  |  |  |  | =item C | 
| 1083 |  |  |  |  |  |  |  | 
| 1084 |  |  |  |  |  |  | The DNS-translated hostname of the IP address held in C. | 
| 1085 |  |  |  |  |  |  | Here, for testing purposes, it is not computed after C but can | 
| 1086 |  |  |  |  |  |  | be freely set.  Defaults to "localhost". | 
| 1087 |  |  |  |  |  |  |  | 
| 1088 |  |  |  |  |  |  | =item C | 
| 1089 |  |  |  |  |  |  |  | 
| 1090 |  |  |  |  |  |  | This read-only variable is only present when making an authenticated GET or | 
| 1091 |  |  |  |  |  |  | POST request.  Its value is the name of the user we are supposed to have | 
| 1092 |  |  |  |  |  |  | successfully authenticated, using the scheme held in C. | 
| 1093 |  |  |  |  |  |  |  | 
| 1094 |  |  |  |  |  |  | =item C | 
| 1095 |  |  |  |  |  |  |  | 
| 1096 |  |  |  |  |  |  | Read-only variable, whose value is either C or C. | 
| 1097 |  |  |  |  |  |  |  | 
| 1098 |  |  |  |  |  |  | =item C | 
| 1099 |  |  |  |  |  |  |  | 
| 1100 |  |  |  |  |  |  | Read-only variable set to the filesystem path of the CGI script being run. | 
| 1101 |  |  |  |  |  |  |  | 
| 1102 |  |  |  |  |  |  | =item C | 
| 1103 |  |  |  |  |  |  |  | 
| 1104 |  |  |  |  |  |  | Read-only variable set to the virtual  path of the CGI script being run, | 
| 1105 |  |  |  |  |  |  | i.e. the path given in the requested URL. | 
| 1106 |  |  |  |  |  |  |  | 
| 1107 |  |  |  |  |  |  | =item C | 
| 1108 |  |  |  |  |  |  |  | 
| 1109 |  |  |  |  |  |  | The host name running the server, which defaults to the host name present | 
| 1110 |  |  |  |  |  |  | in the base URL, provided at creation time as the C<-base_url> argument. | 
| 1111 |  |  |  |  |  |  |  | 
| 1112 |  |  |  |  |  |  | =item C | 
| 1113 |  |  |  |  |  |  |  | 
| 1114 |  |  |  |  |  |  | The port where the server listens, which defaults to the port present | 
| 1115 |  |  |  |  |  |  | in the base URL, provided at creation time as the C<-base_url> argument. | 
| 1116 |  |  |  |  |  |  | If no port was explicitely given, 80 is assumed. | 
| 1117 |  |  |  |  |  |  |  | 
| 1118 |  |  |  |  |  |  | =item C | 
| 1119 |  |  |  |  |  |  |  | 
| 1120 |  |  |  |  |  |  | The protocol which must be followed when replying to the client request. | 
| 1121 |  |  |  |  |  |  | Set to "HTTP/1.1" by default. | 
| 1122 |  |  |  |  |  |  |  | 
| 1123 |  |  |  |  |  |  | =item C | 
| 1124 |  |  |  |  |  |  |  | 
| 1125 |  |  |  |  |  |  | The name of the server software.  Defaults to "CGI::Test". | 
| 1126 |  |  |  |  |  |  |  | 
| 1127 |  |  |  |  |  |  | =back | 
| 1128 |  |  |  |  |  |  |  | 
| 1129 |  |  |  |  |  |  | =head1 BUGS | 
| 1130 |  |  |  |  |  |  |  | 
| 1131 |  |  |  |  |  |  | There are some, most probably.  Please notify me about them. | 
| 1132 |  |  |  |  |  |  |  | 
| 1133 |  |  |  |  |  |  | The following limitations (in decreasing amount of importance) | 
| 1134 |  |  |  |  |  |  | are known and may be lifted one day -- patches welcome: | 
| 1135 |  |  |  |  |  |  |  | 
| 1136 |  |  |  |  |  |  | =over 4 | 
| 1137 |  |  |  |  |  |  |  | 
| 1138 |  |  |  |  |  |  | =item * | 
| 1139 |  |  |  |  |  |  |  | 
| 1140 |  |  |  |  |  |  | There is no support for cookies.  A CGI installing cookies and expecting | 
| 1141 |  |  |  |  |  |  | them to be resent on further invocations to friendly scripts is bound | 
| 1142 |  |  |  |  |  |  | to disappointment. | 
| 1143 |  |  |  |  |  |  |  | 
| 1144 |  |  |  |  |  |  | =item * | 
| 1145 |  |  |  |  |  |  |  | 
| 1146 |  |  |  |  |  |  | There is no support for plain document retrieval: only CGI scripts can | 
| 1147 |  |  |  |  |  |  | be fetched by an HTTP request for now. | 
| 1148 |  |  |  |  |  |  |  | 
| 1149 |  |  |  |  |  |  | =back | 
| 1150 |  |  |  |  |  |  |  | 
| 1151 |  |  |  |  |  |  | =head1 PUBLIC REPOSITORY | 
| 1152 |  |  |  |  |  |  |  | 
| 1153 |  |  |  |  |  |  | CGI::Test now has a publicly accessible Git server provided by Github.com: | 
| 1154 |  |  |  |  |  |  | L | 
| 1155 |  |  |  |  |  |  |  | 
| 1156 |  |  |  |  |  |  | =head1 REPORTING BUGS | 
| 1157 |  |  |  |  |  |  |  | 
| 1158 |  |  |  |  |  |  | Please use Github issue tracker to open bug reports and maintenance | 
| 1159 |  |  |  |  |  |  | requests. | 
| 1160 |  |  |  |  |  |  |  | 
| 1161 |  |  |  |  |  |  | =head1 AUTHORS | 
| 1162 |  |  |  |  |  |  |  | 
| 1163 |  |  |  |  |  |  | The original author is Raphael Manfredi. | 
| 1164 |  |  |  |  |  |  |  | 
| 1165 |  |  |  |  |  |  | Steven Hilton was long time maintainer of this module. | 
| 1166 |  |  |  |  |  |  |  | 
| 1167 |  |  |  |  |  |  | Current maintainer is Alex Tokarev Ftokarev@cpan.orgE>. | 
| 1168 |  |  |  |  |  |  |  | 
| 1169 |  |  |  |  |  |  | =head1 LICENSE | 
| 1170 |  |  |  |  |  |  |  | 
| 1171 |  |  |  |  |  |  | This program is free software; you can redistribute it and/or modify | 
| 1172 |  |  |  |  |  |  | it under the terms of the Artistic License, a copy of which can be | 
| 1173 |  |  |  |  |  |  | found with Perl 5.6.0. | 
| 1174 |  |  |  |  |  |  |  | 
| 1175 |  |  |  |  |  |  | This program is distributed in the hope that it will be useful, | 
| 1176 |  |  |  |  |  |  | but WITHOUT ANY WARRANTY; without even the implied warranty of | 
| 1177 |  |  |  |  |  |  | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the | 
| 1178 |  |  |  |  |  |  | Artistic License for more details. | 
| 1179 |  |  |  |  |  |  |  | 
| 1180 |  |  |  |  |  |  | =head1 SEE ALSO | 
| 1181 |  |  |  |  |  |  |  | 
| 1182 |  |  |  |  |  |  | CGI(3), CGI::Test::Page(3), CGI::Test::Form(3), CGI::Test::Input(3), | 
| 1183 |  |  |  |  |  |  | CGI::Test::Form::Widget(3), HTTP::Status(3), URI(3). | 
| 1184 |  |  |  |  |  |  |  | 
| 1185 |  |  |  |  |  |  | =cut | 
| 1186 |  |  |  |  |  |  |  |