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