1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
#!/usr/bin/perl -w
use strict;
use HTML::Mason::CGIHandler;
use CGI qw(-no_debug); # Prevent "(offline mode: enter name=value pairs on standard input)"
{
# This class simulates CGI requests. It's rather ugly, it tries
# to fool HTML::Mason::Tests into thinking that CGIHandler is a subclass of Interp.
package CGITest;
use HTML::Mason::Tests;
use base 'HTML::Mason::Tests';
sub _run_test
{
my $self = shift;
my $test = $self->{current_test};
$self->{buffer} = '';
my %interp_params = ( exists $test->{interp_params} ?
%{ $test->{interp_params} } :
() );
my $interp = HTML::Mason::CGIHandler->new
(comp_root => $self->comp_root,
data_dir => $self->data_dir,
%interp_params,
);
eval { $self->_execute($interp) };
return $self->check_result($@);
}
sub _execute
{
my ($self, $interp) = @_; # $interp is a CGIHandler object
my $test = $self->{current_test};
#print "Calling $test->{name} test with path: $test->{call_path}\n" if $DEBUG;
$test->{pretest_code}->() if $test->{pretest_code};
CGI::initialize_globals(); # make sure CGI doesn't cache previous query
$ENV{REQUEST_METHOD} = 'GET'; # CGI.pm needs this, or it won't process args
$ENV{PATH_INFO} = $test->{call_path};
$ENV{QUERY_STRING} = join '=', @{$test->{call_args}};
$interp->handle_request($self->{buffer});
}
}
$ENV{DOCUMENT_ROOT} = CGITest->comp_root;
my $group = CGITest->new( name => 'cgi',
description => 'HTML::Mason::CGIHandler class',
interp_class => 'HTML::Mason::CGIHandler',
);
#------------------------------------------------------------
my $basic_header = "Content-Type: text/html";
$basic_header .= '; charset=ISO-8859-1' if CGI->can('charset');
$basic_header .= "${CGI::CRLF}${CGI::CRLF}";
$group->add_test( name => 'basic',
description => 'Test basic CGIHandler operation',
component => 'some text',
expect => "${basic_header}some text",
);
#------------------------------------------------------------
$group->add_test( name => 'dynamic',
description => 'Test CGIHandler operation with dynamic components',
component => 'some <% "dynamic" %> text',
expect => "${basic_header}some dynamic text",
);
#------------------------------------------------------------
$group->add_test( name => 'args',
description => 'Test CGIHandler operation with arguments',
call_args => [arg => 'dynamic'],
component => 'some <% $ARGS{arg} %> text',
expect => "${basic_header}some dynamic text",
);
#------------------------------------------------------------
$group->add_test( name => 'cgi_object',
description => 'Test access to the CGI request object',
call_args => [arg => 'boohoo'],
component => q{some <% $m->cgi_object->param('arg') %> cryin'},
expect => "${basic_header}some boohoo cryin'",
);
#------------------------------------------------------------
$group->add_test( name => 'fatal_error',
description => 'Test fatal error_mode',
interp_params => { error_mode => 'fatal', error_format => 'text' },
component => q{% die 'dead';},
expect_error => qr/dead at .+/,
);
#------------------------------------------------------------
$group->add_test( name => 'headers',
description => 'Test header generation',
component => q{% $r->header_out('foo' => 'bar');},
expect => qr/Foo: bar/i,
);
#------------------------------------------------------------
$group->add_test( name => 'redirect headers',
description => 'Test header generation',
component => q{% $m->redirect('/hello.html');},
expect => qr/Status: 302\s+Location: \/hello\.html|Location: \/hello\.html\s+Status: 302/i,
);
#------------------------------------------------------------
$group->run;
|
