Commit | Line | Data |
be957fec |
1 | package CatalystX::Controller::WrapCGI; |
2 | |
3 | # AUTHOR: Matt S Trout, mst@shadowcatsystems.co.uk |
4 | # Original development sponsored by http://www.altinity.com/ |
5 | |
6 | use strict; |
7 | use warnings; |
8 | use base 'Catalyst::Controller'; |
9 | |
10 | use HTTP::Request::AsCGI; |
11 | use HTTP::Request; |
f1f85b40 |
12 | use URI; |
be957fec |
13 | |
14 | # Hack-around because Catalyst::Engine::HTTP goes and changes |
15 | # them to be the remote socket, and FCGI.pm does even dumber things. |
16 | |
17 | open(*REAL_STDIN, "<&=".fileno(*STDIN)); |
18 | open(*REAL_STDOUT, ">>&=".fileno(*STDOUT)); |
19 | |
20 | sub cgi_to_response { |
21 | my ($self, $c, $script) = @_; |
22 | my $res = $self->wrap_cgi($c, $script); |
23 | |
24 | # if the CGI doesn't set the response code but sets location they were |
25 | # probably trying to redirect so set 302 for them |
26 | |
f1f85b40 |
27 | my $location = $res->headers->header('Location'); |
28 | |
29 | if (defined $location && length $location && $res->code == 200) { |
be957fec |
30 | $c->res->status(302); |
31 | } else { |
32 | $c->res->status($res->code); |
33 | } |
34 | $c->res->body($res->content); |
35 | $c->res->headers($res->headers); |
36 | } |
37 | |
38 | sub wrap_cgi { |
39 | my ($self, $c, $call) = @_; |
40 | my $req = HTTP::Request->new( |
41 | map { $c->req->$_ } qw/method uri headers/ |
42 | ); |
43 | my $body = $c->req->body; |
44 | my $body_content = ''; |
45 | |
46 | $req->content_type($c->req->content_type); # set this now so we can override |
47 | |
48 | if ($body) { # Slurp from body filehandle |
49 | local $/; $body_content = <$body>; |
50 | } else { |
51 | my $body_params = $c->req->body_parameters; |
f1f85b40 |
52 | if (%$body_params) { |
53 | my $encoder = URI->new; |
54 | $encoder->query_form(%$body_params); |
55 | $body_content = $encoder->query; |
be957fec |
56 | $req->content_type('application/x-www-form-urlencoded'); |
57 | } |
58 | } |
59 | |
be957fec |
60 | $req->content($body_content); |
61 | $req->content_length(length($body_content)); |
62 | my $user = (($c->can('user_exists') && $c->user_exists) |
f1f85b40 |
63 | ? eval { $c->user->obj->username } |
be957fec |
64 | : ''); |
65 | my $env = HTTP::Request::AsCGI->new( |
66 | $req, |
67 | REMOTE_USER => $user, |
f1f85b40 |
68 | %ENV |
be957fec |
69 | ); |
70 | |
71 | { |
72 | local *STDIN = \*REAL_STDIN; # restore the real ones so the filenos |
73 | local *STDOUT = \*REAL_STDOUT; # are 0 and 1 for the env setup |
74 | |
75 | my $old = select(REAL_STDOUT); # in case somebody just calls 'print' |
76 | |
77 | my $saved_error; |
78 | |
79 | $env->setup; |
80 | eval { $call->() }; |
81 | $saved_error = $@; |
82 | $env->restore; |
83 | |
84 | select($old); |
85 | |
86 | warn "CGI invoke failed: $saved_error" if $saved_error; |
87 | |
88 | } |
89 | |
90 | return $env->response; |
91 | } |
92 | |
93 | 1; |