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