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
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
|
#!perl -w
use strict;
use FindBin qw($Bin);
use File::Spec::Functions qw(catdir);
use Test::More tests => 27;
use CGI qw(-no_debug);
use HTML::Mason::CGIHandler;
BEGIN {
unshift @INC, catdir $Bin, 'lib';
}
use TieOut;
BEGIN { use_ok('MasonX::Interp::WithCallbacks') }
my $key = 'myCallbackTester';
my $cbs = [];
$ENV{PATH_INFO} = '/dhandler';
$ENV{REQUEST_METHOD} = 'GET';
##############################################################################
# This will tie off STDOUT so that it doesn't print do the terminal during
# tests.
my $stdout = tie *STDOUT, 'TieOut' or die "Cannot tie STDOUT: $!\n";
my $outbuf;
##############################################################################
# We'll use this subroutine to clear out various buffers between each test.
sub clear_bufs {
$outbuf = '';
CGI::initialize_globals();
$stdout->read;
}
##############################################################################
# Set up callback functions.
##############################################################################
# Simple callback.
sub simple {
my $cb = shift;
isa_ok( $cb, 'Params::Callback' );
isa_ok( $cb->cb_request, 'Params::CallbackRequest' );
my $params = $cb->params;
$params->{result} = 'Success';
}
push @$cbs, { pkg_key => $key,
cb_key => 'simple',
cb => \&simple
};
##############################################################################
# Abort callbacks.
sub test_abort {
my $cb = shift;
isa_ok( $cb, 'Params::Callback');
$cb->abort($cb->value);
}
push @$cbs, { pkg_key => $key,
cb_key => 'test_abort',
cb => \&test_abort
};
##############################################################################
# Check the aborted value.
sub test_aborted {
my $cb = shift;
isa_ok( $cb, 'Params::Callback');
my $params = $cb->params;
my $val = $cb->value;
eval { $cb->abort(1) } if $val;
$params->{result} = $cb->aborted($@) ? 'yes' : 'no';
}
push @$cbs, { pkg_key => $key,
cb_key => 'test_aborted',
cb => \&test_aborted
};
##############################################################################
# Set up a redirection callback.
my $url = 'https://example.com/';
sub redir {
my $cb = shift;
my $wait = $cb->value;
$cb->redirect($url, $wait);
}
push @$cbs, { pkg_key => $key,
cb_key => 'redir',
cb => \&redir
};
##############################################################################
# Set up a callback to add a header that we can then check for.
sub add_header {
my $cb = shift;
isa_ok( $cb, 'Params::Callback');
my $r = $cb->apache_req;
$r->header_out(Age => 42);
}
push @$cbs, { pkg_key => $key,
cb_key => 'add_header',
cb => \&add_header
};
##############################################################################
# Set up Mason objects.
##############################################################################
ok( my $cgih = HTML::Mason::CGIHandler->new
( comp_root => catdir($Bin, qw(htdocs)),
callbacks => $cbs,
interp_class => 'MasonX::Interp::WithCallbacks',
out_method => \$outbuf ),
"Construct CGIHandler object" );
isa_ok($cgih, 'HTML::Mason::CGIHandler');
(ok my $interp = $cgih->interp, "Get Interp object" );
isa_ok($interp, 'MasonX::Interp::WithCallbacks');
isa_ok($interp, 'HTML::Mason::Interp');
##############################################################################
# Try a simple callback.
$ENV{QUERY_STRING} = "$key|simple_cb=1";
ok( $cgih->handle_request, "Handle simple callback request" );
is( $outbuf, 'Success', "Check simple result" );
clear_bufs;
##############################################################################
# Make sure that abort works properly. For Mason 1.22 and earlier, we need
# to catch the exception ourselves.
$ENV{QUERY_STRING} = "$key|simple_cb=1" .
"&$key|test_abort_cb0=500";
ok( $cgih->handle_request, "Handle abort callback request" );
is( $outbuf, '', "Check abort result" );
clear_bufs;
##############################################################################
# Test the aborted method.
$ENV{QUERY_STRING} = "$key|test_aborted_cb=1";
ok( $cgih->handle_request, "Handle aborted callback request" );
is( $outbuf, 'yes', "Check aborted result" );
clear_bufs;
##############################################################################
# Test redirect.
$ENV{QUERY_STRING} = "$key|redir_cb=0";
ok( $cgih->handle_request, "Handle redirection request" );
is( $outbuf, '', "Check redirection result" );
ok( my $out = $stdout->read, "Get contents of STDOUT" );
like( $out, qr/^Status: 302 (?:Moved|Found)/m, "Check Status header" );
like( $out, qr/^(?:Moved\s+)?Location: $url/mi, "Check Location header" );
clear_bufs;
##############################################################################
# Make sure that redirect without abort works.
$ENV{QUERY_STRING} = "$key|redir_cb0=1" .
"&$key|add_header_cb9=1";
ok( $cgih->handle_request, "Handle redirect w/o abort" );
ok( my $res = $stdout->read, "Get response headers" );
like( $res, qr/^Status: 302 (?:Moved|Found)/m, "Check for Status header" );
like( $res, qr/^(?:Moved\s+)?Location: $url/mi, "Check for Location header" );
like( $res, qr/^Age: 42/mi, "Check for age header" );
clear_bufs;
__END__
|
