lib/Catalyst/Response.pm

   1 package Catalyst::Response;
   2
   3 use Moose;
   4 use HTTP::Headers;
   5 use Moose::Util::TypeConstraints;
   6 use namespace::autoclean;
   7
   8 with 'MooseX::Emulate::Class::Accessor::Fast';
   9
  10 has _response_cb => (
  11     is      => 'ro',
  12     isa     => 'CodeRef',
  13     writer  => '_set_response_cb',
  14     clearer => '_clear_response_cb',
  15     predicate => '_has_response_cb',
  16 );
  17
  18 subtype 'Catalyst::Engine::Types::Writer',
  19     as duck_type([qw(write close)]);
  20
  21 has _writer => (
  22     is      => 'ro',
  23     isa     => 'Catalyst::Engine::Types::Writer',
  24     writer  => '_set_writer',
  25     clearer => '_clear_writer',
  26     predicate => '_has_writer',
  27 );
  28
  29 has write_fh => (
  30   is=>'ro',
  31   predicate=>'_has_write_fh',
  32   lazy=>1,
  33   builder=>'_build_write_fh',
  34 );
  35
  36 sub _build_write_fh {
  37   my $self = shift;
  38   $self->_context->finalize_headers unless
  39     $self->finalized_headers;
  40   $self->_writer;
  41 };
  42
  43 sub DEMOLISH {
  44   my $self = shift;
  45   return if $self->_has_write_fh;
  46   if($self->_has_writer) {
  47     $self->_writer->close
  48   }
  49 }
  50
  51 has cookies   => (is => 'rw', default => sub { {} });
  52 has body      => (is => 'rw', default => undef);
  53 sub has_body { defined($_[0]->body) }
  54
  55 has location  => (is => 'rw');
  56 has status    => (is => 'rw', default => 200);
  57 has finalized_headers => (is => 'rw', default => 0);
  58 has headers   => (
  59   is      => 'rw',
  60   isa => 'HTTP::Headers',
  61   handles => [qw(content_encoding content_length content_type header)],
  62   default => sub { HTTP::Headers->new() },
  63   required => 1,
  64   lazy => 1,
  65 );
  66 has _context => (
  67   is => 'rw',
  68   weak_ref => 1,
  69   clearer => '_clear_context',
  70 );
  71
  72 sub output { shift->body(@_) }
  73
  74 sub code   { shift->status(@_) }
  75
  76 sub write {
  77     my ( $self, $buffer ) = @_;
  78
  79     # Finalize headers if someone manually writes output
  80     $self->_context->finalize_headers unless $self->finalized_headers;
  81
  82     $buffer = q[] unless defined $buffer;
  83
  84     my $len = length($buffer);
  85     $self->_writer->write($buffer);
  86
  87     return $len;
  88 }
  89
  90 sub finalize_headers {
  91     my ($self) = @_;
  92
  93     # This is a less-than-pretty hack to avoid breaking the old
  94     # Catalyst::Engine::PSGI. 5.9 Catalyst::Engine sets a response_cb and
  95     # expects us to pass headers to it here, whereas Catalyst::Enngine::PSGI
  96     # just pulls the headers out of $ctx->response in its run method and never
  97     # sets response_cb. So take the lack of a response_cb as a sign that we
  98     # don't need to set the headers.
  99
 100     return unless $self->_has_response_cb;
 101
 102     # If we already have a writer, we already did this, so don't do it again
 103     return if $self->_has_writer;
 104
 105     my @headers;
 106     $self->headers->scan(sub { push @headers, @_ });
 107
 108     my $writer = $self->_response_cb->([ $self->status, \@headers ]);
 109     $self->_set_writer($writer);
 110     $self->_clear_response_cb;
 111
 112     return;
 113 }
 114
 115 sub from_psgi_response {
 116     my ($self, $psgi_res) = @_;
 117     if(ref $psgi_res eq 'ARRAY') {
 118         my ($status, $headers, $body) = @$psgi_res;
 119         $self->status($status);
 120         $self->headers(HTTP::Headers->new(@$headers));
 121         if(ref $body eq 'ARRAY') {
 122           $self->body(join '', grep defined, @$body);
 123         } else {
 124           $self->body($body);
 125         }
 126     } elsif(ref $psgi_res eq 'CODE') {
 127         $psgi_res->(sub {
 128             my $response = shift;
 129             my ($status, $headers, $maybe_body) = @$response;
 130             $self->status($status);
 131             $self->headers(HTTP::Headers->new(@$headers));
 132             if($maybe_body) {
 133                 if(ref $maybe_body eq 'ARRAY') {
 134                   $self->body(join '', grep defined, @$maybe_body);
 135                 } else {
 136                   $self->body($maybe_body);
 137                 }
 138             } else {
 139                 return $self->write_fh;
 140             }
 141         });
 142      } else {
 143         die "You can't set a Catalyst response from that, expect a valid PSGI response";
 144     }
 145 }
 146
 147 =head1 NAME
 148
 149 Catalyst::Response - stores output responding to the current client request
 150
 151 =head1 SYNOPSIS
 152
 153     $res = $c->response;
 154     $res->body;
 155     $res->code;
 156     $res->content_encoding;
 157     $res->content_length;
 158     $res->content_type;
 159     $res->cookies;
 160     $res->header;
 161     $res->headers;
 162     $res->output;
 163     $res->redirect;
 164     $res->status;
 165     $res->write;
 166
 167 =head1 DESCRIPTION
 168
 169 This is the Catalyst Response class, which provides methods for responding to
 170 the current client request. The appropriate L<Catalyst::Engine> for your environment
 171 will turn the Catalyst::Response into a HTTP Response and return it to the client.
 172
 173 =head1 METHODS
 174
 175 =head2 $res->body( $text | $fh | $iohandle_object )
 176
 177     $c->response->body('Catalyst rocks!');
 178
 179 Sets or returns the output (text or binary data). If you are returning a large body,
 180 you might want to use a L<IO::Handle> type of object (Something that implements the read method
 181 in the same fashion), or a filehandle GLOB. Catalyst
 182 will write it piece by piece into the response.
 183
 184 When using a L<IO::Handle> type of object and no content length has been
 185 already set in the response headers Catalyst will make a reasonable attempt
 186 to determine the size of the Handle. Depending on the implementation of your
 187 handle object, setting the content length may fail. If it is at all possible
 188 for you to determine the content length of your handle object,
 189 it is recomended that you set the content length in the response headers
 190 yourself, which will be respected and sent by Catalyst in the response.
 191
 192 =head2 $res->has_body
 193
 194 Predicate which returns true when a body has been set.
 195
 196 =head2 $res->code
 197
 198 Alias for $res->status.
 199
 200 =head2 $res->content_encoding
 201
 202 Shortcut for $res->headers->content_encoding.
 203
 204 =head2 $res->content_length
 205
 206 Shortcut for $res->headers->content_length.
 207
 208 =head2 $res->content_type
 209
 210 Shortcut for $res->headers->content_type.
 211
 212 This value is typically set by your view or plugin. For example,
 213 L<Catalyst::Plugin::Static::Simple> will guess the mime type based on the file
 214 it found, while L<Catalyst::View::TT> defaults to C<text/html>.
 215
 216 =head2 $res->cookies
 217
 218 Returns a reference to a hash containing cookies to be set. The keys of the
 219 hash are the cookies' names, and their corresponding values are hash
 220 references used to construct a L<CGI::Simple::Cookie> object.
 221
 222     $c->response->cookies->{foo} = { value => '123' };
 223
 224 The keys of the hash reference on the right correspond to the L<CGI::Simple::Cookie>
 225 parameters of the same name, except they are used without a leading dash.
 226 Possible parameters are:
 227
 228 =over
 229
 230 =item value
 231
 232 =item expires
 233
 234 =item domain
 235
 236 =item path
 237
 238 =item secure
 239
 240 =item httponly
 241
 242 =back
 243
 244 =head2 $res->header
 245
 246 Shortcut for $res->headers->header.
 247
 248 =head2 $res->headers
 249
 250 Returns an L<HTTP::Headers> object, which can be used to set headers.
 251
 252     $c->response->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
 253
 254 =head2 $res->output
 255
 256 Alias for $res->body.
 257
 258 =head2 $res->redirect( $url, $status )
 259
 260 Causes the response to redirect to the specified URL. The default status is
 261 C<302>.
 262
 263     $c->response->redirect( 'http://slashdot.org' );
 264     $c->response->redirect( 'http://slashdot.org', 307 );
 265
 266 This is a convenience method that sets the Location header to the
 267 redirect destination, and then sets the response status.  You will
 268 want to C< return > or C<< $c->detach() >> to interrupt the normal
 269 processing flow if you want the redirect to occur straight away.
 270
 271 B<Note:> do not give a relative URL as $url, i.e: one that is not fully
 272 qualified (= C<http://...>, etc.) or that starts with a slash
 273 (= C</path/here>). While it may work, it is not guaranteed to do the right
 274 thing and is not a standard behaviour. You may opt to use uri_for() or
 275 uri_for_action() instead.
 276
 277 =cut
 278
 279 sub redirect {
 280     my $self = shift;
 281
 282     if (@_) {
 283         my $location = shift;
 284         my $status   = shift || 302;
 285
 286         $self->location($location);
 287         $self->status($status);
 288     }
 289
 290     return $self->location;
 291 }
 292
 293 =head2 $res->location
 294
 295 Sets or returns the HTTP 'Location'.
 296
 297 =head2 $res->status
 298
 299 Sets or returns the HTTP status.
 300
 301     $c->response->status(404);
 302
 303 $res->code is an alias for this, to match HTTP::Response->code.
 304
 305 =head2 $res->write( $data )
 306
 307 Writes $data to the output stream.
 308
 309 =head2 $res->write_fh
 310
 311 Returns a PSGI $writer object that has two methods, write and close.  You can
 312 close over this object for asynchronous and nonblocking applications.  For
 313 example (assuming you are using a supporting server, like L<Twiggy>
 314
 315     package AsyncExample::Controller::Root;
 316
 317     use Moose;
 318
 319     BEGIN { extends 'Catalyst::Controller' }
 320
 321     sub prepare_cb {
 322       my $write_fh = pop;
 323       return sub {
 324         my $message = shift;
 325         $write_fh->write("Finishing: $message\n");
 326         $write_fh->close;
 327       };
 328     }
 329
 330     sub anyevent :Local :Args(0) {
 331       my ($self, $c) = @_;
 332       my $cb = $self->prepare_cb($c->res->write_fh);
 333
 334       my $watcher;
 335       $watcher = AnyEvent->timer(
 336         after => 5,
 337         cb => sub {
 338           $cb->(scalar localtime);
 339           undef $watcher; # cancel circular-ref
 340         });
 341     }
 342
 343 =head2 $res->print( @data )
 344
 345 Prints @data to the output stream, separated by $,.  This lets you pass
 346 the response object to functions that want to write to an L<IO::Handle>.
 347
 348 =head2 $self->finalize_headers($c)
 349
 350 Writes headers to response if not already written
 351
 352 =head2 from_psgi_response
 353
 354 Given a PSGI response (either three element ARRAY reference OR coderef expecting
 355 a $responder) set the response from it.
 356
 357 Properly supports streaming and delayed response and / or async IO if running
 358 under an expected event loop.
 359
 360 Example:
 361
 362     package MyApp::Web::Controller::Test;
 363
 364     use base 'Catalyst::Controller';
 365     use Plack::App::Directory;
 366
 367
 368     my $app = Plack::App::Directory->new({ root => "/path/to/htdocs" })
 369       ->to_app;
 370
 371     sub myaction :Local Args {
 372       my ($self, $c) = @_;
 373       $c->res->from_psgi_response($app->($c->req->env));
 374     }
 375
 376 Please note this does not attempt to map or nest your PSGI application under
 377 the Controller and Action namespace or path.
 378
 379 =head2 DEMOLISH
 380
 381 Ensures that the response is flushed and closed at the end of the
 382 request.
 383
 384 =head2 meta
 385
 386 Provided by Moose
 387
 388 =cut
 389
 390 sub print {
 391     my $self = shift;
 392     my $data = shift;
 393
 394     defined $self->write($data) or return;
 395
 396     for (@_) {
 397         defined $self->write($,) or return;
 398         defined $self->write($_) or return;
 399     }
 400     defined $self->write($\) or return;
 401
 402     return 1;
 403 }
 404
 405 =head1 AUTHORS
 406
 407 Catalyst Contributors, see Catalyst.pm
 408
 409 =head1 COPYRIGHT
 410
 411 This library is free software. You can redistribute it and/or modify
 412 it under the same terms as Perl itself.
 413
 414 =cut
 415
 416 __PACKAGE__->meta->make_immutable;
 417
 418 1;