lib/Catalyst/Engine/HTTP/Base.pm

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