lib/Catalyst/Request/REST.pm

   1 #
   2 # REST.pm
   3 # Created by: Adam Jacob, Marchex, <adam@hjksolutions.com>
   4 # Created on: 10/13/2006 03:54:33 PM PDT
   5 #
   6
   7 package Catalyst::Request::REST;
   8 use Moose;
   9 extends qw/Catalyst::Request/;
  10 with qw/Catalyst::RequestRole::REST Catalyst::RequestRole::Deserialize/;
  11
  12 use Catalyst::Utils;
  13
  14 sub _insert_self_into {
  15   my ($class, $app_class ) = @_;
  16   # the fallback to $app_class is for the (rare and deprecated) case when
  17   # people are defining actions in MyApp.pm instead of in a controller.
  18   my $app = (blessed($app_class) && $app_class->can('_application'))
  19         ? $app_class->_application : Catalyst::Utils::class2appclass( $app_class ) || $app_class;
  20
  21   my $req_class = $app->request_class;
  22   return if $req_class->isa($class);
  23   if ($req_class eq 'Catalyst::Request') {
  24     $app->request_class($class);
  25   } else {
  26     die "$app has a custom request class $req_class, "
  27       . "which is not a $class; see Catalyst::Request::REST";
  28   }
  29 }
  30
  31 =head1 NAME
  32
  33 Catalyst::Request::REST - A REST-y subclass of Catalyst::Request
  34
  35 =head1 SYNOPSIS
  36
  37      if ( $c->request->accepts('application/json') ) {
  38          ...
  39      }
  40
  41      my $types = $c->request->accepted_content_types();
  42
  43 =head1 DESCRIPTION
  44
  45 This is a subclass of C<Catalyst::Request> that adds a few methods to
  46 the request object to faciliate writing REST-y code. Currently, these
  47 methods are all related to the content types accepted by the client.
  48
  49 Note that if you have a custom request class in your application, and it does
  50 not inherit from C<Catalyst::Request::REST>, your application will fail with an
  51 error indicating a conflict the first time it tries to use
  52 C<Catalyst::Request::REST>'s functionality.  To fix this error, make sure your
  53 custom request class inherits from C<Catalyst::Request::REST>.
  54
  55 =head1 METHODS
  56
  57 If the request went through the Deserializer action, this method will
  58 returned the deserialized data structure.
  59
  60 =cut
  61
  62 __PACKAGE__->mk_accessors(qw(data accept_only));
  63
  64 =over 4
  65
  66 =item accepted_content_types
  67
  68 Returns an array reference of content types accepted by the
  69 client.
  70
  71 The list of types is created by looking at the following sources:
  72
  73 =over 8
  74
  75 =item * Content-type header
  76
  77 If this exists, this will always be the first type in the list.
  78
  79 =item * content-type parameter
  80
  81 If the request is a GET request and there is a "content-type"
  82 parameter in the query string, this will come before any types in the
  83 Accept header.
  84
  85 =item * Accept header
  86
  87 This will be parsed and the types found will be ordered by the
  88 relative quality specified for each type.
  89
  90 =back
  91
  92 If a type appears in more than one of these places, it is ordered based on
  93 where it is first found.
  94
  95 =cut
  96
  97 sub accepted_content_types {
  98     my $self = shift;
  99
 100     return $self->{content_types} if $self->{content_types};
 101
 102     my %types;
 103
 104     # First, we use the content type in the HTTP Request.  It wins all.
 105     $types{ $self->content_type } = 3
 106         if $self->content_type;
 107
 108     if ($self->method eq "GET" && $self->param('content-type')) {
 109         $types{ $self->param('content-type') } = 2;
 110     }
 111
 112     # Third, we parse the Accept header, and see if the client
 113     # takes a format we understand.
 114     #
 115     # This is taken from chansen's Apache2::UploadProgress.
 116     if ( $self->header('Accept') ) {
 117         $self->accept_only(1) unless keys %types;
 118
 119         my $accept_header = $self->header('Accept');
 120         my $counter       = 0;
 121
 122         foreach my $pair ( split_header_words($accept_header) ) {
 123             my ( $type, $qvalue ) = @{$pair}[ 0, 3 ];
 124             next if $types{$type};
 125
 126             unless ( defined $qvalue ) {
 127                 $qvalue = 1 - ( ++$counter / 1000 );
 128             }
 129
 130             $types{$type} = sprintf( '%.3f', $qvalue );
 131         }
 132     }
 133
 134     return $self->{content_types} =
 135         [ sort { $types{$b} <=> $types{$a} } keys %types ];
 136 }
 137
 138 =item preferred_content_type
 139
 140 This returns the first content type found. It is shorthand for:
 141
 142   $request->accepted_content_types->[0]
 143
 144 =cut
 145
 146 sub preferred_content_type { $_[0]->accepted_content_types->[0] }
 147
 148 =item accepts($type)
 149
 150 Given a content type, this returns true if the type is accepted.
 151
 152 Note that this does not do any wildcard expansion of types.
 153
 154 =cut
 155
 156 sub accepts {
 157     my $self = shift;
 158     my $type = shift;
 159
 160     return grep { $_ eq $type } @{ $self->accepted_content_types };
 161 }
 162
 163 =back
 164
 165 =head1 AUTHOR
 166
 167 Adam Jacob <adam@stalecoffee.org>, with lots of help from mst and jrockway
 168
 169 =head1 MAINTAINER
 170
 171 J. Shirley <jshirley@cpan.org>
 172
 173 =head1 LICENSE
 174
 175 You may distribute this code under the same terms as Perl itself.
 176
 177 =cut
 178
 179 1;