view release on metacpan or  search on metacpan

lib/CGI/Application/Plugin/REST.pm  view on Meta::CPAN

our @EXPORT_OK =
  qw/ rest_error_mode rest_param rest_resource rest_route rest_route_info
  rest_route_prefix /;

our %EXPORT_TAGS = ( 'all' => [@EXPORT_OK] );

=head1 DESCRIPTION

REST stands for REpresentational State Transfer. It is an architecture for web
applications that tries to leverage the existing infrastructure of the World
Wide Web such as URIs, MIME media types, and HTTP instead of building up
protocols and functions on top of them.

This plugin contains a number of functions to support the various REST
concepts. They try to use existing L<CGI::Application|CGI::Application> functionality
wherever possible.

C<use>'ing this plugin will intercept L<CGI::Application|CGI::Application>'s standard dispatch
mechanism.  Instead of being selected based on a query parameter like C<rm>,
the run mode will be determined by comparing URI patterns defined in your app
with the L<rest_route|rest_route()> method.  (Referred from here on, as "routes".)
Optionally, specific HTTP methods or MIME media types can be defined in a
route too.  One by one, each entry in the reverse asciibetically sorted table
of defined routes is compared to the incoming HTTP request and the first
successful match is selected.  The run mode mapped to that route is then
called.

This is done via overriding L<CGI::Application|CGI::Application>'s C<mode_param()> function so
it should be compatible with other L<CGI::Application|CGI::Application> plugins.

=head2 DevPopup Support

If you are using L<C::A::P::DevPopup|CGI::Application::Plugin::DevPopup> (i.e. the environment
variable C<CAP_DEVPOPUP_EXEC> is set,) C<use>'ing this module will register a
callback which will add debug information about the current route (See L<rest_route_info|rest_route_info()>),
parameters (See L<rest_param|rest_param()>) etc.

=head1 FUNCTIONS

The following functions are available.  None of them are exported by default.
You can use the C<:all> tag to import all public functions.

=cut

# Plug in to CGI::Application and setup our callbacks
#
sub import {
    my $caller = scalar caller;

    $caller->add_callback(
        'init',
        sub {
            my ($self) = @_;
            $self->mode_param( \&_rest_dispatch );

            return;
        }
    );
    if ( exists $ENV{'CAP_DEVPOPUP_EXEC'} ) {
        $caller->add_callback( 'devpopup_report', \&_rest_devpopup );
    }
    goto &Exporter::import;
}

# Callback for CGI::Application::Plugin::DevPopup which provides debug info.
#
sub _rest_devpopup {
    my ( $self, $outputref ) = @_;

    my $report = "<table>\n";
    foreach my $key ( sort keys %{ $self->{'__r_params'} } ) {
        my $name = $key;
        $name =~ s/_/ /gmsx;
        $report .= join q{},
          (
            "<tr><td>$name: </td>",        '<td colspan="2">',
            $self->{'__r_params'}->{$key}, "</td></tr>\n"
          );
    }

    # This bit is complicated but necessary as rest_param needs a
    # nested table.
    my @params = rest_param($self);
    my $rows   = scalar @params;
    $report .= qq{<tr><td rowspan="$rows">parameters: </td>};
    foreach my $param (@params) {
        if ( $param ne $params[0] ) {
            $report .= '<tr>';
        }
        $report .= join q{},
          (
            qq{<td>$param: </td><td>},
            rest_param( $self, $param ),
            "</td></tr>\n"
          );
    }
    $report .= "</table>\n";

    $self->devpopup->add_report(
        title   => 'CGI::Application::Plugin::REST',
        summary => 'Information on the current REST dispatch',
        report  => $report,
    );

    return;
}

# mode_param() callback to set the run mode based on the request URI.
#
sub _rest_dispatch {
    my ($self) = @_;

    my $q    = $self->query;
    my $path = $q->path_info;

    # get the module name from the table
    if ( !exists $self->{'__rest_dispatch_table'} ) {
        $self->header_add( -status => '500 No Dispatch Table' );
        return rest_error_mode( $self, $EVAL_ERROR );
    }

    # look at each rule and stop when we get a match
    foreach my $rule ( reverse sort keys %{ $self->{'__rest_dispatch_table'} } )
    {
        my @names = ();

        # $rule will be transformed later so save the original form first.
        my $origrule = $rule;
        $rule = rest_route_prefix($self) . $rule;

        # translate the rule into a regular expression, but remember where
        # the named args are.
        # '/:foo' will become '/([^\/]*)'
        # and
        # '/:bar?' will become '/?([^\/]*)?'
        # and then remember which position it matches
        $rule =~ s{
                        (^ | /)                 # beginning or a /
                        (: ([^/?]+) ([?])?)     # stuff in between
                }{
                        push(@names, $3);
                        $1 . ( $4 ? '?( [^/]* )?' : '([^/]*)')
                }egsmx;

        # '/*' onwards will become '(.*)\$'
        if ( $rule =~ m{/[*] .* $}msx ) {
            $rule =~ s{(/[*] .* )$}{/(.*)\$}msx;
            push @names, 'dispatch_uri_remainder';
        }

        # if we found a match, then run with it
        if ( my @values = ( $path =~ m{^$rule$}msx ) ) {

            $self->{'__match'} = $path;
            my $table = $self->{'__rest_dispatch_table'}->{$origrule};

            # next check request method.
            my $method = request_method($q);