lib/Catalyst/Engine/HTTP/Base.pm

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