lib/Catalyst/Action/REST.pm

   1 #
   2 # REST.pm
   3 # Created by: Adam Jacob, Marchex, <adam@marchex.com>
   4 # Created on: 10/12/2006 03:00:32 PM PDT
   5 #
   6 # $Id$
   7
   8 package Catalyst::Action::REST;
   9
  10 use strict;
  11 use warnings;
  12
  13 use base 'Catalyst::Action';
  14 use Class::Inspector;
  15 use 5.8.1;
  16
  17 our
  18 $VERSION = '0.2';
  19
  20 =head1 NAME
  21
  22 Catalyst::Action::REST - Automated REST Method Dispatching
  23
  24 =head1 SYNOPSIS
  25
  26     sub foo :Local :ActionClass('REST') {}
  27
  28     sub foo_GET {
  29       ... do something for GET requests ...
  30     }
  31
  32     sub foo_PUT {
  33       ... do somethign for PUT requests ...
  34     }
  35
  36 =head1 DESCRIPTION
  37
  38 This Action handles doing automatic method dispatching for REST requests.  It
  39 takes a normal Catalyst action, and changes the dispatch to append an
  40 underscore and method name.
  41
  42 For example, in the synopsis above, calling GET on "/foo" would result in
  43 the foo_GET method being dispatched.
  44
  45 If a method is requested that is not implemented, this action will
  46 return a status 405 (Method Not Found).  It will populate the "Allow" header
  47 with the list of implemented request methods.
  48
  49 It is likely that you really want to look at L<Catalyst::Controller::REST>.
  50
  51 =head1 METHODS
  52
  53 =over 4
  54
  55 =item dispatch
  56
  57 This method overrides the default dispatch mechanism to the re-dispatching
  58 mechanism described above.
  59
  60 =cut
  61
  62 sub dispatch {
  63     my $self = shift;
  64     my $c    = shift;
  65
  66     my $controller = $self->class;
  67     my $method     = $self->name . "_" . uc( $c->request->method );
  68     if ( $controller->can($method) ) {
  69         $c->execute( $self->class, $self, @{ $c->req->args } );
  70         return $controller->$method( $c, @{ $c->req->args } );
  71     } else {
  72         if ( $c->request->method eq "OPTIONS" ) {
  73             return $self->_return_options($c);
  74         } else {
  75             my $handle_ni = $self->name . "_not_implemented";
  76             if ( $controller->can($handle_ni) ) {
  77                 return $controller->$handle_ni( $c, @{ $c->req->args } );
  78             } else {
  79                 return $self->_return_not_implemented($c);
  80             }
  81         }
  82     }
  83 }
  84
  85 sub _return_options {
  86     my ( $self, $c ) = @_;
  87
  88     my @allowed = $self->_get_allowed_methods($c);
  89     $c->response->content_type('text/plain');
  90     $c->response->status(200);
  91     $c->response->header( 'Allow' => \@allowed );
  92 }
  93
  94 sub _get_allowed_methods {
  95     my ( $self, $c ) = @_;
  96
  97     my $controller = $self->class;
  98     my $methods    = Class::Inspector->methods($controller);
  99     my @allowed;
 100     foreach my $method ( @{$methods} ) {
 101         my $name = $self->name;
 102         if ( $method =~ /^$name\_(.+)$/ ) {
 103             push( @allowed, $1 );
 104         }
 105     }
 106     return @allowed;
 107 }
 108
 109 sub _return_not_implemented {
 110     my ( $self, $c ) = @_;
 111
 112     my @allowed = $self->_get_allowed_methods($c);
 113     $c->response->content_type('text/plain');
 114     $c->response->status(405);
 115     $c->response->header( 'Allow' => \@allowed );
 116     $c->response->body( "Method "
 117           . $c->request->method
 118           . " not implemented for "
 119           . $c->uri_for( $self->reverse ) );
 120 }
 121
 122 1;
 123
 124 =back
 125
 126 =head1 SEE ALSO
 127
 128 You likely want to look at L<Catalyst::Controller::REST>, which implements
 129 a sensible set of defaults for a controller doing REST.
 130
 131 L<Catalyst::Action::Serialize>, L<Catalyst::Action::Deserialize>
 132
 133 =head1 AUTHOR
 134
 135 Adam Jacob <adam@stalecoffee.org>, with lots of help from mst and jrockway
 136
 137 Marchex, Inc. paid me while I developed this module.  (http://www.marchex.com)
 138
 139 =head1 CONTRIBUTERS
 140
 141 Daisuke Maki <daisuke@endeworks.jp>
 142
 143 =head1 LICENSE
 144
 145 You may distribute this code under the same terms as Perl itself.
 146
 147 =cut
 148