lib/Catalyst/Engine/HTTP.pm

   1 package Catalyst::Engine::HTTP;
   2
   3 use strict;
   4 use base 'Catalyst::Engine';
   5
   6 use CGI::Simple::Cookie;
   7 use Class::Struct ();
   8 use HTTP::Headers::Util 'split_header_words';
   9 use HTTP::Request;
  10 use HTTP::Response;
  11 use IO::File;
  12 use URI;
  13
  14 __PACKAGE__->mk_accessors(qw/http/);
  15
  16 Class::Struct::struct 'Catalyst::Engine::HTTP::LWP' => {
  17     request  => 'HTTP::Request',
  18     response => 'HTTP::Response',
  19     hostname => '$',
  20     address  => '$'
  21 };
  22
  23 =head1 NAME
  24
  25 Catalyst::Engine::HTTP - Catalyst HTTP Engine
  26
  27 =head1 SYNOPSIS
  28
  29 L<Catalyst>.
  30
  31 =head1 DESCRIPTION
  32
  33 This Catalyst engine is meant to be subclassed.
  34
  35 =head1 OVERLOADED METHODS
  36
  37 This class overloads some methods from C<Catalyst::Engine>.
  38
  39 =over 4
  40
  41 =item $c->finalize_headers
  42
  43 =cut
  44
  45 sub finalize_headers {
  46     my $c = shift;
  47
  48     my $status   = $c->response->status || 200;
  49     my $headers  = $c->response->headers;
  50     my $response = HTTP::Response->new( $status, undef, $headers );
  51
  52     while ( my ( $name, $cookie ) = each %{ $c->response->cookies } ) {
  53         my $cookie = CGI::Simple::Cookie->new(
  54             -name    => $name,
  55             -value   => $cookie->{value},
  56             -expires => $cookie->{expires},
  57             -domain  => $cookie->{domain},
  58             -path    => $cookie->{path},
  59             -secure  => $cookie->{secure} || 0
  60         );
  61
  62         $response->header( 'Set-Cookie' => $cookie->as_string );
  63     }
  64
  65     $c->http->response($response);
  66 }
  67
  68 =item $c->finalize_output
  69
  70 =cut
  71
  72 sub finalize_output {
  73     my $c = shift;
  74     $c->http->response->content_ref( \$c->response->{output} );
  75 }
  76
  77 =item $c->prepare_connection
  78
  79 =cut
  80
  81 sub prepare_connection {
  82     my $c = shift;
  83     $c->req->hostname( $c->http->hostname );
  84     $c->req->address( $c->http->address );
  85 }
  86
  87 =item $c->prepare_cookies
  88
  89 =cut
  90
  91 sub prepare_cookies {
  92     my $c = shift;
  93
  94     if ( my $header = $c->http->request->header('Cookie') ) {
  95         $c->req->cookies( { CGI::Simple::Cookie->parse($header) } );
  96     }
  97 }
  98
  99 =item $c->prepare_headers
 100
 101 =cut
 102
 103 sub prepare_headers {
 104     my $c = shift;
 105     $c->req->method( $c->http->request->method );
 106     $c->req->headers( $c->http->request->headers );
 107 }
 108
 109 =item $c->prepare_parameters
 110
 111 =cut
 112
 113 sub prepare_parameters {
 114     my $c = shift;
 115
 116     my @params  = ();
 117     my $request = $c->http->request;
 118
 119     push( @params, $request->uri->query_form );
 120
 121     if ( $request->content_type eq 'application/x-www-form-urlencoded' ) {
 122         my $uri = URI->new('http:');
 123         $uri->query( $request->content );
 124         push( @params, $uri->query_form );
 125     }
 126
 127     if ( $request->content_type eq 'multipart/form-data' ) {
 128
 129         for my $part ( $request->parts ) {
 130
 131             my $disposition = $part->header('Content-Disposition');
 132             my %parameters  = @{ ( split_header_words($disposition) )[0] };
 133
 134             if ( $parameters{filename} ) {
 135
 136                 my $fh = IO::File->new_tmpfile;
 137                 $fh->write( $part->content ) or die $!;
 138                 $fh->seek( SEEK_SET, 0 ) or die $!;
 139
 140                 $c->req->uploads->{ $parameters{filename} } = {
 141                     fh   => $fh,
 142                     size => ( stat $fh )[7],
 143                     type => $part->content_type
 144                 };
 145
 146                 push( @params, $parameters{filename}, $fh );
 147             }
 148             else {
 149                 push( @params, $parameters{name}, $part->content );
 150             }
 151         }
 152     }
 153
 154     my $parameters = $c->req->parameters;
 155
 156     while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) {
 157
 158         if ( exists $parameters->{$name} ) {
 159             for ( $parameters->{$name} ) {
 160                 $_ = [$_] unless ref($_) eq "ARRAY";
 161                 push( @$_, $value );
 162             }
 163         }
 164         else {
 165             $parameters->{$name} = $value;
 166         }
 167     }
 168 }
 169
 170 =item $c->prepare_path
 171
 172 =cut
 173
 174 sub prepare_path {
 175     my $c = shift;
 176
 177     my $base;
 178     {
 179         my $scheme = $c->http->request->uri->scheme;
 180         my $host   = $c->http->request->uri->host;
 181         my $port   = $c->http->request->uri->port;
 182
 183         $base = URI->new;
 184         $base->scheme($scheme);
 185         $base->host($host);
 186         $base->port($port);
 187
 188         $base = $base->canonical->as_string;
 189     }
 190
 191     my $path = $c->http->request->uri->path || '/';
 192     $path =~ s/^\///;
 193
 194     $c->req->base($base);
 195     $c->req->path($path);
 196 }
 197
 198 =item $c->prepare_request($r)
 199
 200 =cut
 201
 202 sub prepare_request {
 203     my ( $c, $http ) = @_;
 204     $c->http($http);
 205 }
 206
 207 =item $c->prepare_uploads
 208
 209 =cut
 210
 211 sub prepare_uploads {
 212     my $c = shift;
 213 }
 214
 215 =back
 216
 217 =head1 SEE ALSO
 218
 219 L<Catalyst>.
 220
 221 =head1 AUTHOR
 222
 223 Sebastian Riedel, C<sri@cpan.org>
 224 Christian Hansen, C<ch@ngmedia.com>
 225
 226 =head1 COPYRIGHT
 227
 228 This program is free software, you can redistribute it and/or modify it under
 229 the same terms as Perl itself.
 230
 231 =cut
 232
 233 1;