line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
################################################################# |
2
|
|
|
|
|
|
|
# Copyright (c) 2001, Raphael Manfredi |
3
|
|
|
|
|
|
|
# Copyright (c) 2011-2016, 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
|
|
352266
|
use strict; |
|
23
|
|
|
|
|
33
|
|
|
23
|
|
|
|
|
530
|
|
12
|
23
|
|
|
23
|
|
73
|
use warnings; |
|
23
|
|
|
|
|
1050
|
|
|
23
|
|
|
|
|
460
|
|
13
|
|
|
|
|
|
|
|
14
|
23
|
|
|
23
|
|
63
|
use Carp; |
|
23
|
|
|
|
|
29
|
|
|
23
|
|
|
|
|
1143
|
|
15
|
23
|
|
|
23
|
|
7989
|
use HTTP::Status; |
|
23
|
|
|
|
|
58441
|
|
|
23
|
|
|
|
|
3838
|
|
16
|
23
|
|
|
23
|
|
8625
|
use URI; |
|
23
|
|
|
|
|
95859
|
|
|
23
|
|
|
|
|
502
|
|
17
|
23
|
|
|
23
|
|
11715
|
use File::Temp qw(mkstemp); |
|
23
|
|
|
|
|
254587
|
|
|
23
|
|
|
|
|
1051
|
|
18
|
23
|
|
|
23
|
|
101
|
use File::Spec; |
|
23
|
|
|
|
|
22
|
|
|
23
|
|
|
|
|
297
|
|
19
|
23
|
|
|
23
|
|
65
|
use File::Basename; |
|
23
|
|
|
|
|
17
|
|
|
23
|
|
|
|
|
1210
|
|
20
|
23
|
|
|
23
|
|
73
|
use Cwd qw(abs_path); |
|
23
|
|
|
|
|
23
|
|
|
23
|
|
|
|
|
628
|
|
21
|
|
|
|
|
|
|
|
22
|
23
|
|
|
23
|
|
157
|
use vars qw($VERSION); |
|
23
|
|
|
|
|
21
|
|
|
23
|
|
|
|
|
1343
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
$VERSION = '1.111'; |
25
|
|
|
|
|
|
|
|
26
|
23
|
|
|
23
|
|
72
|
use constant WINDOWS => eval { $^O =~ /Win32|cygwin/ }; |
|
23
|
|
|
|
|
23
|
|
|
23
|
|
|
|
|
20
|
|
|
23
|
|
|
|
|
56728
|
|
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
|
4740
|
my $this = bless {}, shift; |
45
|
25
|
|
|
|
|
77
|
my %params = @_; |
46
|
|
|
|
|
|
|
|
47
|
25
|
|
|
|
|
54
|
my $ubase = $params{-base_url}; |
48
|
25
|
|
|
|
|
44
|
my $dir = $params{-cgi_dir}; |
49
|
25
|
|
50
|
|
|
147
|
my $doc = $params{-doc_dir} || "."; |
50
|
25
|
|
50
|
|
|
202
|
my $tmp = $params{-tmp_dir} || $ENV{TMPDIR} || $ENV{TEMP} || "/tmp"; |
51
|
25
|
|
|
|
|
45
|
my $env = $params{-cgi_env}; |
52
|
|
|
|
|
|
|
|
53
|
25
|
|
|
|
|
100
|
my $uri = URI->new($ubase); |
54
|
25
|
50
|
33
|
|
|
109056
|
croak "-base_url $ubase is not within the http scheme" |
55
|
|
|
|
|
|
|
unless ( $uri->scheme eq 'http' || $uri->scheme eq 'https' ); |
56
|
|
|
|
|
|
|
|
57
|
25
|
|
|
|
|
1684
|
my ($server, $path) = $this->split_uri($uri); |
58
|
25
|
|
|
|
|
308
|
$this->{host_port} = $server; |
59
|
25
|
|
|
|
|
68
|
$this->{scheme} = $uri->scheme; |
60
|
25
|
|
|
|
|
351
|
$this->{host} = $uri->host; |
61
|
25
|
|
|
|
|
637
|
$this->{port} = $uri->port; |
62
|
25
|
|
|
|
|
463
|
$this->{base_path} = $path; |
63
|
25
|
|
|
|
|
40
|
$this->{cgi_dir} = $dir; |
64
|
25
|
|
|
|
|
33
|
$this->{tmp_dir} = $tmp; |
65
|
25
|
100
|
|
|
|
79
|
$env = {} unless defined $env; |
66
|
25
|
|
|
|
|
39
|
$this->{cgi_env} = $env; |
67
|
25
|
|
|
|
|
31
|
$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
|
|
|
|
|
67
|
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
|
|
|
|
|
947
|
while (my ($key, $value) = each %dflt) |
89
|
|
|
|
|
|
|
{ |
90
|
300
|
100
|
|
|
|
801
|
$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
|
|
|
|
|
70
|
$this->{_obj_type} = {'text/plain' => 'Text', |
99
|
|
|
|
|
|
|
'text/html' => 'HTML', |
100
|
|
|
|
|
|
|
}; |
101
|
|
|
|
|
|
|
|
102
|
25
|
|
|
|
|
201
|
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
|
55
|
my $this = shift; |
122
|
44
|
|
|
|
|
86
|
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
|
46
|
my $this = shift; |
156
|
44
|
|
|
|
|
95
|
return $this->{base_path}; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
###################################################################### |
160
|
|
|
|
|
|
|
sub cgi_dir |
161
|
|
|
|
|
|
|
{ |
162
|
44
|
|
|
44
|
1
|
51
|
my $this = shift; |
163
|
44
|
|
|
|
|
65
|
return $this->{cgi_dir}; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
###################################################################### |
167
|
|
|
|
|
|
|
sub doc_dir |
168
|
|
|
|
|
|
|
{ |
169
|
16
|
|
|
16
|
1
|
40
|
my $this = shift; |
170
|
16
|
|
|
|
|
99
|
return $this->{doc_dir}; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
###################################################################### |
174
|
|
|
|
|
|
|
sub tmp_dir |
175
|
|
|
|
|
|
|
{ |
176
|
62
|
|
|
62
|
1
|
82
|
my $this = shift; |
177
|
62
|
|
|
|
|
711
|
return $this->{tmp_dir}; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
###################################################################### |
181
|
|
|
|
|
|
|
sub cgi_env |
182
|
|
|
|
|
|
|
{ |
183
|
210
|
|
|
210
|
0
|
165
|
my $this = shift; |
184
|
210
|
|
|
|
|
1000
|
return $this->{cgi_env}; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
###################################################################### |
188
|
|
|
|
|
|
|
sub _obj_type |
189
|
|
|
|
|
|
|
{ |
190
|
28
|
|
|
28
|
|
46
|
my $this = shift; |
191
|
28
|
|
|
|
|
192
|
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
|
|
2313
|
my $this = shift; |
214
|
69
|
|
|
|
|
97
|
my ($dir) = @_; |
215
|
69
|
50
|
|
|
|
327
|
my $root = ($dir =~ s|^/||) ? "/" : ""; |
216
|
69
|
|
|
|
|
75
|
my @cur; |
217
|
69
|
|
|
|
|
215
|
foreach my $item (split(m|/|, $dir)) |
218
|
|
|
|
|
|
|
{ |
219
|
119
|
50
|
|
|
|
203
|
next if $item eq '.'; |
220
|
119
|
50
|
|
|
|
153
|
if ($item eq '..') |
221
|
|
|
|
|
|
|
{ |
222
|
0
|
|
|
|
|
0
|
pop(@cur); |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
else |
225
|
|
|
|
|
|
|
{ |
226
|
119
|
|
|
|
|
163
|
push(@cur, $item); |
227
|
|
|
|
|
|
|
} |
228
|
|
|
|
|
|
|
} |
229
|
69
|
|
|
|
|
192
|
my $path = $root . join('/', @cur); |
230
|
69
|
|
|
|
|
160
|
$path =~ tr|/||s; |
231
|
69
|
|
|
|
|
751
|
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
|
92
|
my $this = shift; |
244
|
69
|
|
|
|
|
84
|
my ($uri) = @_; |
245
|
69
|
|
|
|
|
187
|
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
|
6188
|
my $this = shift; |
263
|
42
|
|
|
|
|
59
|
my ($uri, $user) = @_; |
264
|
|
|
|
|
|
|
|
265
|
42
|
|
|
|
|
114
|
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
|
4
|
my $this = shift; |
285
|
2
|
|
|
|
|
2
|
my ($uri, $input, $user) = @_; |
286
|
|
|
|
|
|
|
|
287
|
2
|
|
|
|
|
30
|
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
|
|
45
|
my $this = shift; |
300
|
44
|
|
|
|
|
50
|
my ($uri, $user, $input) = @_; # $input defined for POST |
301
|
|
|
|
|
|
|
|
302
|
44
|
|
|
|
|
104
|
my $u = URI->new($uri); |
303
|
44
|
50
|
|
|
|
1915
|
croak "URI $uri is not within the http scheme" |
304
|
|
|
|
|
|
|
unless $u->scheme eq 'http'; |
305
|
|
|
|
|
|
|
|
306
|
44
|
|
|
|
|
8423
|
require CGI::Test::Page::Error; |
307
|
44
|
|
|
|
|
72
|
my $error = "CGI::Test::Page::Error"; |
308
|
|
|
|
|
|
|
|
309
|
44
|
|
|
|
|
110
|
my ($userver, $upath, $uquery) = $this->split_uri($u); |
310
|
44
|
|
|
|
|
437
|
my $server = $this->host_port; |
311
|
44
|
|
|
|
|
101
|
my $base_path = $this->base_path . "/"; |
312
|
|
|
|
|
|
|
|
313
|
44
|
50
|
|
|
|
130
|
croak "URI $uri is not located on server $server" |
314
|
|
|
|
|
|
|
unless $userver eq $server; |
315
|
|
|
|
|
|
|
|
316
|
44
|
50
|
|
|
|
131
|
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
|
|
|
|
|
78
|
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
|
|
|
|
|
87
|
my $cgi_dir = $this->cgi_dir; |
329
|
44
|
|
|
|
|
116
|
my @components = split(m|/|, $upath); |
330
|
44
|
|
|
|
|
42
|
my @script; |
331
|
|
|
|
|
|
|
|
332
|
44
|
|
|
|
|
103
|
while (@components) |
333
|
|
|
|
|
|
|
{ |
334
|
47
|
|
|
|
|
75
|
my $item = shift @components; |
335
|
47
|
100
|
|
|
|
1265
|
if (-e File::Spec->catfile($cgi_dir, @script, $item)) |
336
|
|
|
|
|
|
|
{ |
337
|
44
|
|
|
|
|
149
|
push(@script, $item); |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
else |
340
|
|
|
|
|
|
|
{ |
341
|
3
|
|
|
|
|
9
|
unshift @components, $item; |
342
|
3
|
|
|
|
|
3
|
last; |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
44
|
|
|
|
|
225
|
my $script = File::Spec->catfile($cgi_dir, @script); # Real |
347
|
44
|
|
|
|
|
101
|
my $script_name = $base_path . join("/", @script); # Virtual |
348
|
44
|
|
|
|
|
79
|
my $path = "/" . join("/", @components); # Virtual |
349
|
|
|
|
|
|
|
|
350
|
44
|
50
|
|
|
|
291
|
return $error->new(RC_NOT_FOUND, $this) unless -f $script; |
351
|
44
|
50
|
|
|
|
280
|
return $error->new(RC_UNAUTHORIZED, $this) unless -x $script; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# |
354
|
|
|
|
|
|
|
# Prepare input for POST requests. |
355
|
|
|
|
|
|
|
# |
356
|
|
|
|
|
|
|
|
357
|
44
|
|
|
|
|
69
|
my @post = (); |
358
|
44
|
|
|
|
|
562
|
local $SIG{PIPE} = 'IGNORE'; |
359
|
44
|
|
|
|
|
125
|
local (*PREAD, *PWRITE); |
360
|
|
|
|
|
|
|
|
361
|
44
|
|
|
|
|
49
|
my ($in_fh, $out_fh, $in_fname, $out_fname); |
362
|
|
|
|
|
|
|
|
363
|
44
|
100
|
|
|
|
111
|
if (defined $input) { |
364
|
|
|
|
|
|
|
# In Windows, we use temp files instead of pipes to avoid |
365
|
|
|
|
|
|
|
# stream duplication errors |
366
|
2
|
50
|
|
|
|
18
|
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
|
|
|
|
|
14
|
-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
|
|
|
|
|
146
|
($out_fh, $out_fname) = |
399
|
|
|
|
|
|
|
mkstemp(File::Spec->catfile($this->tmp_dir, "cgi_out.XXXXXX")); |
400
|
|
|
|
|
|
|
|
401
|
44
|
50
|
|
|
|
12159
|
close $out_fh if WINDOWS; |
402
|
|
|
|
|
|
|
|
403
|
44
|
|
|
|
|
284
|
select((select(STDOUT), $| = 1)[ 0 ]); |
404
|
44
|
|
|
|
|
109
|
print STDOUT ""; # Flush STDOUT before forking |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# |
407
|
|
|
|
|
|
|
# Fork... |
408
|
|
|
|
|
|
|
# |
409
|
|
|
|
|
|
|
|
410
|
44
|
|
|
|
|
25354
|
my $pid = fork; |
411
|
44
|
50
|
|
|
|
1439
|
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
|
|
|
|
582
|
if ($pid == 0) { |
421
|
16
|
100
|
66
|
|
|
669
|
close PWRITE if defined $input && !WINDOWS; # Writing side of the pipe |
422
|
|
|
|
|
|
|
|
423
|
16
|
|
|
|
|
1189
|
$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
|
|
|
|
1212
|
close $out_fh unless WINDOWS; |
442
|
|
|
|
|
|
|
|
443
|
28
|
100
|
66
|
|
|
220
|
if (defined $input && !WINDOWS) |
444
|
|
|
|
|
|
|
{ # Send POST input data |
445
|
1
|
|
|
|
|
14
|
close PREAD; |
446
|
1
|
|
|
|
|
55
|
syswrite PWRITE, $input->data, $input->length; |
447
|
1
|
50
|
|
|
|
6
|
close PWRITE or warn "failure while closing pipe: $!"; |
448
|
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
|
450
|
28
|
|
|
|
|
14893645
|
my $child = waitpid $pid, 0; |
451
|
|
|
|
|
|
|
|
452
|
28
|
50
|
|
|
|
345
|
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
|
|
|
|
|
407
|
my $header = $this->_parse_header($out_fname); |
466
|
28
|
50
|
|
|
|
117
|
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
|
|
|
238
|
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
|
|
|
|
|
82
|
$this->{http_headers} = $header; |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# |
489
|
|
|
|
|
|
|
# Create proper page object, which will parse the results file as needed. |
490
|
|
|
|
|
|
|
# |
491
|
|
|
|
|
|
|
|
492
|
28
|
|
|
|
|
88
|
my $type = $header->{'Content-Type'}; |
493
|
28
|
|
|
|
|
74
|
my $base_type = lc($type); |
494
|
28
|
|
|
|
|
105
|
$base_type =~ s/;.*//; # Strip type parameters |
495
|
28
|
|
50
|
|
|
153
|
my $objtype = $this->_obj_type->{$base_type} || "Other"; |
496
|
28
|
|
|
|
|
65
|
$objtype = "CGI::Test::Page::$objtype"; |
497
|
|
|
|
|
|
|
|
498
|
28
|
|
|
|
|
2758
|
eval "require $objtype"; |
499
|
28
|
50
|
|
|
|
158
|
die "can't load module $objtype: $@" if chop $@; |
500
|
|
|
|
|
|
|
|
501
|
28
|
|
|
|
|
212
|
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
|
|
|
|
83
|
if ($in_fname) { |
510
|
0
|
0
|
|
|
|
0
|
unlink $in_fname or warn "can't unlink $in_fname: $!"; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
28
|
50
|
|
|
|
190112
|
unlink $out_fname or warn "can't unlink $out_fname: $!"; |
514
|
|
|
|
|
|
|
|
515
|
28
|
|
|
|
|
688
|
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
|
|
184
|
my $this = shift; |
536
|
|
|
|
|
|
|
|
537
|
16
|
|
|
|
|
614
|
my %params = @_; |
538
|
|
|
|
|
|
|
|
539
|
16
|
|
|
|
|
128
|
my $script = $params{-script_file}; |
540
|
16
|
|
|
|
|
74
|
my $name = $params{-script_name}; |
541
|
16
|
|
|
|
|
91
|
my $user = $params{-user}; |
542
|
16
|
|
|
|
|
54
|
my $in = $params{-in}; |
543
|
16
|
|
|
|
|
245
|
my $in_fname = $params{-in_fname}; |
544
|
16
|
|
|
|
|
54
|
my $out = $params{-out}; |
545
|
16
|
|
|
|
|
61
|
my $out_fname = $params{-out_fname}; |
546
|
16
|
|
|
|
|
45
|
my $u = $params{-uri}; |
547
|
16
|
|
|
|
|
46
|
my $path = $params{-path_info}; |
548
|
16
|
|
|
|
|
41
|
my $input = $params{-input}; |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# |
551
|
|
|
|
|
|
|
# Connect file descriptors. |
552
|
|
|
|
|
|
|
# |
553
|
|
|
|
|
|
|
|
554
|
16
|
50
|
|
|
|
473
|
if ( !WINDOWS ) { |
555
|
16
|
100
|
|
|
|
163
|
if (defined $in) |
556
|
|
|
|
|
|
|
{ |
557
|
1
|
50
|
|
|
|
60
|
open(STDIN, '<&=' . fileno($in)) || die "can't redirect STDIN: $!"; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
else |
560
|
|
|
|
|
|
|
{ |
561
|
15
|
|
|
|
|
1098
|
my $devnull = File::Spec->devnull; |
562
|
15
|
50
|
|
|
|
1325
|
open(STDIN, $devnull) || die "can't open $devnull: $!"; |
563
|
|
|
|
|
|
|
} |
564
|
16
|
50
|
|
|
|
428
|
open(STDOUT, '>&=' . fileno($out)) || die "can't redirect STDOUT: $!"; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
# |
568
|
|
|
|
|
|
|
# Setup default CGI environment. |
569
|
|
|
|
|
|
|
# |
570
|
|
|
|
|
|
|
|
571
|
16
|
|
|
|
|
61
|
while (my ($key, $value) = each %{$this->cgi_env}) |
|
210
|
|
|
|
|
367
|
|
572
|
|
|
|
|
|
|
{ |
573
|
194
|
|
|
|
|
1861
|
$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
|
|
|
|
107
|
if (defined $input) |
582
|
|
|
|
|
|
|
{ |
583
|
1
|
|
|
|
|
9
|
$ENV{CONTENT_TYPE} = $input->mime_type; |
584
|
1
|
|
|
|
|
22
|
$ENV{CONTENT_LENGTH} = $input->length; |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
else |
587
|
|
|
|
|
|
|
{ |
588
|
15
|
|
|
|
|
110
|
delete $ENV{CONTENT_TYPE}; |
589
|
15
|
|
|
|
|
82
|
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
|
|
|
|
109
|
$ENV{REQUEST_METHOD} = defined $input ? "POST" : "GET"; |
598
|
16
|
|
|
|
|
50
|
$ENV{PATH_INFO} = $path; |
599
|
16
|
|
|
|
|
66
|
$ENV{SCRIPT_NAME} = $name; |
600
|
16
|
|
|
|
|
52
|
$ENV{SCRIPT_FILENAME} = $script; |
601
|
16
|
|
|
|
|
438
|
$ENV{HTTP_HOST} = $u->host_port; |
602
|
|
|
|
|
|
|
|
603
|
16
|
50
|
|
|
|
1350
|
if (length $path) |
604
|
|
|
|
|
|
|
{ |
605
|
16
|
|
|
|
|
74
|
$ENV{PATH_TRANSLATED} = $this->doc_dir . $path; |
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
else |
608
|
|
|
|
|
|
|
{ |
609
|
0
|
|
|
|
|
0
|
delete $ENV{PATH_TRANSLATED}; |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
|
612
|
16
|
100
|
|
|
|
59
|
if (defined $user) |
613
|
|
|
|
|
|
|
{ |
614
|
1
|
|
|
|
|
3
|
$ENV{REMOTE_USER} = $user; |
615
|
|
|
|
|
|
|
} |
616
|
|
|
|
|
|
|
else |
617
|
|
|
|
|
|
|
{ |
618
|
15
|
|
|
|
|
50
|
delete $ENV{REMOTE_USER}; |
619
|
15
|
|
|
|
|
38
|
delete $ENV{AUTH_TYPE}; |
620
|
|
|
|
|
|
|
} |
621
|
|
|
|
|
|
|
|
622
|
16
|
100
|
|
|
|
144
|
if (defined $u->query) |
623
|
|
|
|
|
|
|
{ |
624
|
12
|
|
|
|
|
249
|
$ENV{QUERY_STRING} = $u->query; |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
else |
627
|
|
|
|
|
|
|
{ |
628
|
4
|
|
|
|
|
84
|
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
|
|
|
|
|
165
|
$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
|
|
|
|
72
|
my $path_sep = WINDOWS ? ';' : ':'; |
648
|
|
|
|
|
|
|
|
649
|
16
|
50
|
|
|
|
127
|
$ENV{PERL5LIB} = join($path_sep, map {-e $_ ? abs_path($_) : $_} @INC); |
|
167
|
|
|
|
|
6879
|
|
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
|
|
|
|
|
103
|
$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
|
|
|
|
|
1508
|
my $directory = dirname($script); |
663
|
16
|
|
|
|
|
338
|
my $basename = basename($script); |
664
|
|
|
|
|
|
|
|
665
|
16
|
50
|
|
|
|
222
|
chdir $directory or die "can't cd to $directory: $!"; |
666
|
|
|
|
|
|
|
|
667
|
16
|
50
|
|
|
|
106
|
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
|
|
82
|
my $this = shift; |
694
|
28
|
|
|
|
|
111
|
my ($file) = @_; |
695
|
28
|
|
|
|
|
55
|
my %header; |
696
|
28
|
|
|
|
|
187
|
local *FILE; |
697
|
28
|
50
|
|
|
|
1582
|
open(FILE, $file) || warn "can't open $file: $!"; |
698
|
28
|
|
|
|
|
131
|
local $_; |
699
|
28
|
|
|
|
|
58
|
my $field; |
700
|
|
|
|
|
|
|
|
701
|
28
|
|
|
|
|
680
|
while () |
702
|
|
|
|
|
|
|
{ |
703
|
72
|
100
|
66
|
|
|
583
|
last if /^\015?\012$/ || /^\015\012$/; |
704
|
44
|
|
|
|
|
309
|
s/\015?\012$//; |
705
|
44
|
50
|
|
|
|
437
|
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
|
|
|
|
|
436
|
$field =~ s/(\w+)/\u\L$1/g; # Normalize spelling |
713
|
44
|
50
|
|
|
|
124
|
if (exists $header{$field}) |
714
|
|
|
|
|
|
|
{ |
715
|
0
|
|
|
|
|
0
|
warn "duplicate $field header in $file"; |
716
|
0
|
|
|
|
|
0
|
$header{$field} .= " "; |
717
|
|
|
|
|
|
|
} |
718
|
44
|
|
|
|
|
345
|
$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
|
|
|
|
|
195
|
close FILE; |
728
|
28
|
|
|
|
|
226
|
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
|
|
|
|
|
|
|
|