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     $c->request->secure(1) if ( $c->http->request->uri->port == 443 );
  79 }
  80
  81 =item $c->prepare_headers
  82
  83 =cut
  84
  85 sub prepare_headers {
  86     my $c = shift;
  87     $c->request->method( $c->http->request->method );
  88     $c->request->headers( $c->http->request->headers );
  89 }
  90
  91 =item $c->prepare_parameters
  92
  93 =cut
  94
  95 sub prepare_parameters {
  96     my $c = shift;
  97
  98     my ( @params, @uploads );
  99
 100     my $request = $c->http->request;
 101
 102     push( @params, $request->uri->query_form );
 103
 104     if ( $request->content_type eq 'application/x-www-form-urlencoded' ) {
 105         my $uri = URI->new('http:');
 106         $uri->query( $request->content );
 107         push( @params, $uri->query_form );
 108     }
 109
 110     if ( $request->content_type eq 'multipart/form-data' ) {
 111
 112         for my $part ( $request->parts ) {
 113
 114             my $disposition = $part->header('Content-Disposition');
 115             my %parameters  = @{ ( split_header_words($disposition) )[0] };
 116
 117             if ( $parameters{filename} ) {
 118
 119                 my $fh = File::Temp->new( UNLINK => 0 );
 120
 121                 unless ( $fh->write( $part->content ) ) {
 122                     Catalyst::Exception->throw( message => $! );
 123                 }
 124
 125                 unless ( $fh->flush ) {
 126                     Catalyst::Exception->throw( message => $! );
 127                 }
 128
 129                 my $upload = Catalyst::Request::Upload->new(
 130                     filename => $parameters{filename},
 131                     size     => ( $fh->stat )[7],
 132                     tempname => $fh->filename,
 133                     type     => $part->content_type
 134                 );
 135
 136                 unless ( $fh->close ) {
 137                     Catalyst::Exception->throw( message => $! );
 138                 }
 139
 140                 push( @uploads, $parameters{name}, $upload );
 141                 push( @params,  $parameters{name}, $parameters{filename} );
 142             }
 143             else {
 144                 push( @params, $parameters{name}, $part->content );
 145             }
 146         }
 147     }
 148
 149     $c->request->param(@params);
 150     $c->request->upload(@uploads);
 151 }
 152
 153 =item $c->prepare_path
 154
 155 =cut
 156
 157 sub prepare_path {
 158     my $c = shift;
 159
 160     my $base;
 161     {
 162         my $scheme = $c->http->request->uri->scheme;
 163         my $host   = $c->http->request->uri->host;
 164         my $port   = $c->http->request->uri->port;
 165
 166         $base = URI->new;
 167         $base->scheme($scheme);
 168         $base->host($host);
 169         $base->port($port);
 170
 171         $base = $base->canonical->as_string;
 172     }
 173
 174     my $path = $c->http->request->uri->path || '/';
 175     $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
 176     $path =~ s/^\///;
 177
 178     $c->req->base($base);
 179     $c->req->path($path);
 180 }
 181
 182 =item $c->prepare_request($r)
 183
 184 =cut
 185
 186 sub prepare_request {
 187     my ( $c, $http ) = @_;
 188     $c->http($http);
 189 }
 190
 191 =item $c->prepare_uploads
 192
 193 =cut
 194
 195 sub prepare_uploads {
 196     my $c = shift;
 197 }
 198
 199 =back
 200
 201 =head1 SEE ALSO
 202
 203 L<Catalyst>.
 204
 205 =head1 AUTHOR
 206
 207 Sebastian Riedel, C<sri@cpan.org>
 208 Christian Hansen, C<ch@ngmedia.com>
 209
 210 =head1 COPYRIGHT
 211
 212 This program is free software, you can redistribute it and/or modify it under
 213 the same terms as Perl itself.
 214
 215 =cut
 216
 217 1;