package CGI::Application::Plugin::REST; use warnings; use strict; use Carp; use base 'Exporter'; our @EXPORT = qw/ REST_error REST_route REST_media_type /; # remember to keep version number in sync with the POD below our $VERSION = '0.8'; # plug in to CGI::Application and setup our callbacks. sub import{ my $caller = scalar(caller); $caller->add_callback('init', 'CGI::Application::Plugin::REST::REST_init'); $caller->add_callback('prerun', 'CGI::Application::Plugin::REST::REST_dispatch'); goto &Exporter::import; } # REST_init # Set up our variables # sub REST_init { my ($self) = @_; $self->{REST_dispatch_table} = {}; $self->{REST_my_media_type} = undef; } # REST_dispatch # A cgiapp_prerun hook that maps requests to the right functions # sub REST_dispatch { my ($self, $run_mode) = @_; my $q = $self->query; # Is this a REST run_mode? Yes then wrap the whole thing up in an eval if (exists($self->{REST_dispatch_table}->{$run_mode})) { eval { my $rest_run_mode = $self->{REST_dispatch_table}->{$run_mode}; # If so, create a dummy real run_mode for it (or supress an existing # one.) This is becuse we run fro cgiapp_prerun() which wants to # return to a real run_mode. $self->run_modes($run_mode => sub {}); # Is the request method (GET, POST) valid for our REST run_mode? my $request_method = $q->request_method; if (defined($request_method) && exists($rest_run_mode->{$request_method})) { my $dispatch = $rest_run_mode->{$request_method}; # Get the preferred MIME media type. Other HTTP verbs than the # ones below (and DELETE) are not covered. Should they be? my $media_type = undef; if ($request_method eq 'GET' || $request_method eq 'HEAD') { my $quality = 0.000; foreach my $type (keys %$dispatch) { my $temp_quality = $q->Accept($type); if ($temp_quality > $quality) { $quality = $temp_quality; $media_type = $type; } } } elsif ($request_method eq 'POST' || $request_method eq 'PUT') { $media_type = $q->content_type; } $self->{REST_my_media_type} = $media_type; # Is the MIME media type valid for our REST run_mode? DELETE # doesn't care about the media type so skip check in that case. if ((defined($media_type) && exists($dispatch->{$media_type})) || $request_method eq 'DELETE') { # Get the function to call. The rest of the array is the # arguments we want to give to that function... my @args = @{$dispatch->{$media_type}}; my $function = shift @args; # ...which we get from the CGI parameters. my $params; foreach my $arg (@args) { $params->{$arg} = $q->param($arg) || ''; } # Try and run the method passing it a hashref of the arguments. if (my $sub = $self->can($function)) { no strict 'refs'; $self->run_modes( $run_mode => sub { return $sub->($self, $params) } ); } # We couldn't find or run the specified method. else { $self->REST_error('403', "Function doesn't exist"); } } # We didn't get an acceptable MIME media type. else { $self->REST_error('415', 'Unsupported media type'); } } # We didn't get an acceptable request method. else { $self->REST_error('405', 'Method not allowed'); } }}; # trap any errors and pass them on to the error mode. if ($@) { REST_error('500', 'Application error'); my $error = $@; $self->call_hook('error', $error); if (my $em = $self->error_mode) { $self->$em( $error ); } else { croak("Error executing REST run mode '$run_mode': $error"); } } } # REST_error # prepare an error message # sub REST_error { my ($self, $code, $msg) = @_; $self->header_add(-status => "$code $msg"); die "$code $msg\n"; } # REST_media_type # Return the prefered MIME media type # sub REST_media_type { my ($self) = @_; return $self->{REST_my_media_type}; } # REST_route # Add an entry to the dispatch table # sub REST_route { my $self = shift; my %params = ( RUN_MODE => $self->start_mode, REQUEST_METHOD => 'GET', MEDIA_TYPES => ['*/*'], FUNCTION => [$self->start_mode()], @_, ); foreach my $type (@{$params{MEDIA_TYPES}}) { $self->{REST_dispatch_table}->{$params{RUN_MODE}}-> {$params{REQUEST_METHOD}}->{$type} = $params{FUNCTION}; } } 1;